1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE OverloadedStrings #-}
4-- | NOTE: This module is a highly experimental preview release. It may change
5-- drastically, or be entirely removed, in a future release.
6module Data.Yaml.Parser where
7
8import Control.Applicative
9import Control.Exception (Exception)
10import Control.Monad (MonadPlus (..), liftM, ap)
11import Control.Monad.Trans.Class (lift)
12import Control.Monad.Trans.Resource (MonadThrow, throwM)
13import Control.Monad.Trans.Writer.Strict (tell, WriterT)
14import Data.ByteString (ByteString)
15import Data.Conduit
16import Data.Conduit.Lift (runWriterC)
17import qualified Data.Map as Map
18#if !MIN_VERSION_base(4,8,0)
19import Data.Monoid (Monoid (..))
20#endif
21#if !MIN_VERSION_base(4,11,0)
22import Data.Semigroup (Semigroup(..))
23#endif
24import Data.Text (Text, pack, unpack)
25import Data.Text.Encoding (decodeUtf8)
26import Data.Text.Read (signed, decimal)
27import Data.Typeable (Typeable)
28
29import Text.Libyaml
30
31newtype YamlParser a = YamlParser
32    { unYamlParser :: AnchorMap -> Either Text a
33    }
34instance Functor YamlParser where
35    fmap = liftM
36instance Applicative YamlParser where
37    pure = YamlParser . const . Right
38    (<*>) = ap
39instance Alternative YamlParser where
40    empty = fail "empty"
41    (<|>) = mplus
42instance Semigroup (YamlParser a) where
43    (<>) = mplus
44instance Monoid (YamlParser a) where
45    mempty = fail "mempty"
46#if !MIN_VERSION_base(4,11,0)
47    mappend = (<>)
48#endif
49instance Monad YamlParser where
50    return = pure
51    YamlParser f >>= g = YamlParser $ \am ->
52        case f am of
53            Left t -> Left t
54            Right x -> unYamlParser (g x) am
55#if MIN_VERSION_base(4,13,0)
56instance MonadFail YamlParser where
57#endif
58    fail = YamlParser . const . Left . pack
59instance MonadPlus YamlParser where
60    mzero = fail "mzero"
61    mplus a b = YamlParser $ \am ->
62        case unYamlParser a am of
63            Left _ -> unYamlParser b am
64            x -> x
65
66lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)
67lookupAnchor name = YamlParser $ Right . Map.lookup name
68
69withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
70withAnchor name expected f = do
71    mv <- lookupAnchor name
72    case mv of
73        Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name
74        Just v -> f v
75
76withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a
77withMapping _ f (Mapping m _) = f m
78withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f
79withMapping expected _ v = typeMismatch expected v
80
81withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
82withSequence _ f (Sequence s _) = f s
83withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f
84withSequence expected _ v = typeMismatch expected v
85
86withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
87withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s
88withText expected f (Alias an) = withAnchor an expected $ withText expected f
89withText expected _ v = typeMismatch expected v
90
91typeMismatch :: Text -> YamlValue -> YamlParser a
92typeMismatch expected v =
93    fail $ concat
94        [ "Expected "
95        , unpack expected
96        , ", but got: "
97        , t
98        ]
99  where
100    t = case v of
101        Mapping _ _ -> "mapping"
102        Sequence _ _ -> "sequence"
103        Scalar _ _ _ _ -> "scalar"
104        Alias _ -> "alias"
105
106class FromYaml a where
107    fromYaml :: YamlValue -> YamlParser a
108instance FromYaml YamlValue where
109    fromYaml = return
110instance FromYaml a => FromYaml [a] where
111    fromYaml = withSequence "[a]" (mapM fromYaml)
112instance FromYaml Text where
113    fromYaml = withText "Text" return
114instance FromYaml Int where
115    fromYaml =
116        withText "Int" go
117      where
118        go t =
119            case signed decimal t of
120                Right (i, "") -> return i
121                _ -> fail $ "Invalid Int: " ++ unpack t
122
123data YamlValue
124    = Mapping [(Text, YamlValue)] Anchor
125    | Sequence [YamlValue] Anchor
126    | Scalar ByteString Tag Style Anchor
127    | Alias AnchorName
128    deriving Show
129
130type AnchorMap = Map.Map AnchorName YamlValue
131data RawDoc = RawDoc YamlValue AnchorMap
132    deriving Show
133
134parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a
135parseRawDoc (RawDoc val am) =
136    case unYamlParser (fromYaml val) am of
137        Left t -> throwM $ FromYamlException t
138        Right x -> return x
139
140(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
141o .: k =
142    case lookup k o of
143        Nothing -> fail $ "Key not found: " ++ unpack k
144        Just v -> fromYaml v
145
146data YamlParseException
147    = UnexpectedEndOfEvents
148    | UnexpectedEvent Event
149    | FromYamlException Text
150    deriving (Show, Typeable)
151instance Exception YamlParseException
152
153sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue
154sinkValue =
155    start
156  where
157    start = await >>= maybe (throwM UnexpectedEndOfEvents) go
158
159    tell' Nothing val = return val
160    tell' (Just name) val = do
161        lift $ tell $ Map.singleton name val
162        return val
163
164    go EventStreamStart = start
165    go EventDocumentStart = start
166    go (EventAlias a) = return $ Alias a
167    go (EventScalar a b c d) = tell' d $ Scalar a b c d
168    go (EventSequenceStart _tag _style mname) = do
169        vals <- goS id
170        let val = Sequence vals mname
171        tell' mname val
172    go (EventMappingStart _tag _style mname) = do
173        pairs <- goM id
174        let val = Mapping pairs mname
175        tell' mname val
176
177    go e = throwM $ UnexpectedEvent e
178
179    goS front = do
180        me <- await
181        case me of
182            Nothing -> throwM UnexpectedEndOfEvents
183            Just EventSequenceEnd -> return $ front []
184            Just e -> do
185                val <- go e
186                goS (front . (val:))
187
188    goM front = do
189        mk <- await
190        case mk of
191            Nothing -> throwM UnexpectedEndOfEvents
192            Just EventMappingEnd -> return $ front []
193            Just (EventScalar a b c d) -> do
194                _ <- tell' d $ Scalar a b c d
195                let k = decodeUtf8 a
196                v <- start
197                goM (front . ((k, v):))
198            Just e -> throwM $ UnexpectedEvent e
199
200sinkRawDoc :: MonadThrow m => ConduitM Event o m RawDoc
201sinkRawDoc = uncurry RawDoc <$> runWriterC sinkValue
202
203readYamlFile :: FromYaml a => FilePath -> IO a
204readYamlFile fp = runConduitRes (decodeFile fp .| sinkRawDoc) >>= parseRawDoc
205