git.iko.soy/typeable/yaml
on 06f73cc help sign in
typeable/yaml/src/Data/Yaml/Parser.hs
201 lines 6.4 kB history raw
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
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)
29import Text.Libyaml
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 fail = YamlParser . const . Left . pack
56instance MonadPlus YamlParser where
57 mzero = fail "mzero"
58 mplus a b = YamlParser $ \am ->
59 case unYamlParser a am of
60 Left _ -> unYamlParser b am
61 x -> x
63lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)
64lookupAnchor name = YamlParser $ Right . Map.lookup name
66withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
67withAnchor name expected f = do
68 mv <- lookupAnchor name
69 case mv of
70 Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name
71 Just v -> f v
73withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a
74withMapping _ f (Mapping m _) = f m
75withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f
76withMapping expected _ v = typeMismatch expected v
78withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
79withSequence _ f (Sequence s _) = f s
80withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f
81withSequence expected _ v = typeMismatch expected v
83withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
84withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s
85withText expected f (Alias an) = withAnchor an expected $ withText expected f
86withText expected _ v = typeMismatch expected v
88typeMismatch :: Text -> YamlValue -> YamlParser a
89typeMismatch expected v =
90 fail $ concat
91 [ "Expected "
92 , unpack expected
93 , ", but got: "
94 , t
95 ]
96 where
97 t = case v of
98 Mapping _ _ -> "mapping"
99 Sequence _ _ -> "sequence"
100 Scalar _ _ _ _ -> "scalar"
101 Alias _ -> "alias"
103class FromYaml a where
104 fromYaml :: YamlValue -> YamlParser a
105instance FromYaml YamlValue where
106 fromYaml = return
107instance FromYaml a => FromYaml [a] where
108 fromYaml = withSequence "[a]" (mapM fromYaml)
109instance FromYaml Text where
110 fromYaml = withText "Text" return
111instance FromYaml Int where
112 fromYaml =
113 withText "Int" go
114 where
115 go t =
116 case signed decimal t of
117 Right (i, "") -> return i
118 _ -> fail $ "Invalid Int: " ++ unpack t
120data YamlValue
121 = Mapping [(Text, YamlValue)] Anchor
122 | Sequence [YamlValue] Anchor
123 | Scalar ByteString Tag Style Anchor
124 | Alias AnchorName
125 deriving Show
127type AnchorMap = Map.Map AnchorName YamlValue
128data RawDoc = RawDoc YamlValue AnchorMap
129 deriving Show
131parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a
132parseRawDoc (RawDoc val am) =
133 case unYamlParser (fromYaml val) am of
134 Left t -> throwM $ FromYamlException t
135 Right x -> return x
137(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
138o .: k =
139 case lookup k o of
140 Nothing -> fail $ "Key not found: " ++ unpack k
141 Just v -> fromYaml v
143data YamlParseException
144 = UnexpectedEndOfEvents
145 | UnexpectedEvent Event
146 | FromYamlException Text
147 deriving (Show, Typeable)
148instance Exception YamlParseException
150sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue
151sinkValue =
152 start
153 where
154 start = await >>= maybe (throwM UnexpectedEndOfEvents) go
156 tell' Nothing val = return val
157 tell' (Just name) val = do
158 lift $ tell $ Map.singleton name val
159 return val
161 go EventStreamStart = start
162 go EventDocumentStart = start
163 go (EventAlias a) = return $ Alias a
164 go (EventScalar a b c d) = tell' d $ Scalar a b c d
165 go (EventSequenceStart _tag _style mname) = do
166 vals <- goS id
167 let val = Sequence vals mname
168 tell' mname val
169 go (EventMappingStart _tag _style mname) = do
170 pairs <- goM id
171 let val = Mapping pairs mname
172 tell' mname val
174 go e = throwM $ UnexpectedEvent e
176 goS front = do
177 me <- await
178 case me of
179 Nothing -> throwM UnexpectedEndOfEvents
180 Just EventSequenceEnd -> return $ front []
181 Just e -> do
182 val <- go e
183 goS (front . (val:))
185 goM front = do
186 mk <- await
187 case mk of
188 Nothing -> throwM UnexpectedEndOfEvents
189 Just EventMappingEnd -> return $ front []
190 Just (EventScalar a b c d) -> do
191 _ <- tell' d $ Scalar a b c d
192 let k = decodeUtf8 a
193 v <- start
194 goM (front . ((k, v):))
195 Just e -> throwM $ UnexpectedEvent e
197sinkRawDoc :: MonadThrow m => ConduitM Event o m RawDoc
198sinkRawDoc = uncurry RawDoc <$> runWriterC sinkValue
200readYamlFile :: FromYaml a => FilePath -> IO a
201readYamlFile fp = runConduitRes (decodeFile fp .| sinkRawDoc) >>= parseRawDoc