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