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