@@ -3,232 +3,55 @@
3{-# LANGUAGE CPP #-}
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PackageImports #-}
7{-# LANGUAGE PatternGuards #-}
6{-# LANGUAGE PatternGuards #-}
8−{-|
7+{-# LANGUAGE ScopedTypeVariables #-}
9−As a bit of background, this package is built on a few other packages I wrote.
10−yaml is a low-level wrapper around the C libyaml library, with an enumerator
11−interface. data-object is a package defining a data type:
14− data Object k v = Scalar v
15− | Sequence [Object k v]
16− | Mapping [(k, Object k v)]
19−In other words, it can represent JSON data fully, and YAML data almost fully.
20−In particular, it doesn't handle cyclical aliases, which I hope doesn't really
21−occur too much in real life.
23−Another package to deal with is failure: it basically replaces using an Either
24−for error-handling into a typeclass. It has instances for Maybe, IO and lists
27−The last package is convertible-text, which is a fork of John Goerzen's
28−convertible package. The difference is it supports both conversions that are
29−guaranteed to succeed (Int -> String) and ones which may fail (String -> Int),
30−and also supports various textual datatypes (String, lazy\/strict ByteString,
33−/YamlScalar and YamlObject/
35−We have a @type YamlObject = Object YamlScalar YamlScalar@, where a YamlScalar
36−is just a ByteString value with a tag and a style. A \"style\" is how the data
37−was represented in the underlying YAML file: single quoted, double quoted, etc.
39−Then there is an IsYamlScalar typeclass, which provides fromYamlScalar and
40−toYamlScalar conversion functions. There are instances for all the
41−\"text-like\" datatypes: String, ByteString and Text. The built-in instances
42−all assume a UTF-8 data encoding. And around this we have toYamlObject and
43−fromYamlObject functions, which do exactly what they sound like.
45−/Encoding and decoding/
47−There are two encoding files: encode and encodeFile. You can guess the
48−different: the former produces a ByteString (strict) and the latter writes to a
49−file. They both take an Object, whose keys and values must be an instance of
50−IsYamlScalar. So, for example:
53− encodeFile "myfile.yaml" $ Mapping
54− [ ("Michael", Mapping
55− [ ("age", Scalar "26")
56− , ("color", Scalar "blue")
58− , ("Eliezer", Mapping
59− [ ("age", Scalar "2")
60− , ("color", Scalar "green")
65−decoding is only slightly more complicated, since the decoding can fail. In
66−particular, the return type is an IO wrapped around a Failure. For example, you
70− maybeObject <- decodeFile "myfile.yaml"
72− Nothing -> putStrLn "Error parsing YAML file."
73− Just object -> putStrLn "Successfully parsed."
76−If you just want to throw any parse errors as IO exception, you can use join:
79− import Control.Monad (join)
80− object <- join $ decodeFile "myfile.yaml"
83−This takes advantage of the IO instance of Failure.
87−In order to pull the data out of an Object, you can use the helper functions
88−from Data.Object. For example:
92− import Data.Object.Yaml
96− object <- join $ decodeFile "myfile.yaml"
97− people <- fromMapping object
98− michael <- lookupMapping "Michael" people
99− age <- lookupScalar "age" michael
100− putStrLn $ "Michael is " ++ age ++ " years old."
103−lookupScalar and friends implement Maybe, so you can test for optional
104−attributes by switching on Nothing/Just a:
107− name <- lookupScalar "middleName" michael :: Maybe String
113−There's really not more to know about this library. Enjoy!
115module Data.Yaml
8module Data.Yaml
116− ( -- * Definition of 'YamlObject'
9+ ( -- * Types
117− YamlScalar (..)
10+ Value (..)
118− , YamlObject
11+ , object
119− -- * Automatic scalar conversions
12+ , array
120− , IsYamlScalar (..)
13+ -- * Classes
121− , toYamlObject
14+ , ToJSON (..)
122− , fromYamlObject
15+ , FromJSON (..)
123 -- * Encoding/decoding
16 -- * Encoding/decoding
125 , encodeFile
18 , encodeFile
127 , decodeFile
20 , decodeFile
129− , ParseException (..)
132import qualified Text.Libyaml as Y
23import qualified Text.Libyaml as Y
24+import Data.Aeson (Value (..), ToJSON (..), FromJSON (..), object)
25+import Data.Aeson.Types (Pair, parseMaybe)
133import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
26import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
135import Data.ByteString (ByteString)
27import Data.ByteString (ByteString)
136import qualified Data.Map as Map
28import qualified Data.Map as Map
137import System.IO.Unsafe (unsafePerformIO)
29import System.IO.Unsafe (unsafePerformIO)
138−import Control.Failure (Failure (failure))
30+import Control.Exception (try, throwIO, fromException, Exception)
140−import qualified Data.Text
141−import qualified Data.Text.Lazy
142−import qualified Data.ByteString
143−import qualified Data.ByteString.Lazy
145−import Data.Convertible.Text (cs)
148−import Control.Monad.Trans.Class
149−import Control.Monad.IO.Class
150import Control.Monad.Trans.State
31import Control.Monad.Trans.State
152import qualified Data.Conduit as C
32import qualified Data.Conduit as C
153import qualified Data.Conduit.List as CL
33import qualified Data.Conduit.List as CL
154−import Prelude hiding (catch)
34+import Control.Monad.Trans.Class (MonadTrans, lift)
155−import Control.Exception (throwIO, Exception, fromException, try)
35+import Control.Monad.IO.Class (MonadIO, liftIO)
156−import Data.String (IsString (fromString))
36+import Control.Monad (liftM)
157−
37+import qualified Data.Vector as V
158−-- | Equality depends on 'value' and 'tag', not 'style'.
38+import Data.Text (Text)
159−data YamlScalar = YamlScalar
39+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
160− { value :: ByteString
40+import Data.Text.Encoding.Error (lenientDecode)
161− , tag :: Tag
41+import qualified Data.HashMap.Strict as M
164− deriving (Show, Read, Data, Typeable)
42+import Data.Typeable
165−instance Eq YamlScalar where
43+
166− (YamlScalar v t _) == (YamlScalar v' t' _) = v == v' && t == t'
167−instance IsString YamlScalar where
168− fromString = toYamlScalar
170−type YamlObject = Object YamlScalar YamlScalar
172−class (Eq a) => IsYamlScalar a where
173− fromYamlScalar :: YamlScalar -> a
174− toYamlScalar :: a -> YamlScalar
175−instance IsYamlScalar YamlScalar where
178−instance IsYamlScalar Data.Text.Text where
179− fromYamlScalar = cs . value
180− toYamlScalar t = YamlScalar (cs t) NoTag Any
181−instance IsYamlScalar Data.Text.Lazy.Text where
182− fromYamlScalar = cs . value
183− toYamlScalar t = YamlScalar (cs t) NoTag Any
184−instance IsYamlScalar [Char] where
185− fromYamlScalar = cs . value
186− toYamlScalar s = YamlScalar (cs s) NoTag Any
187−instance IsYamlScalar Data.ByteString.ByteString where
188− fromYamlScalar = value
189− toYamlScalar b = YamlScalar b NoTag Any
190−instance IsYamlScalar Data.ByteString.Lazy.ByteString where
191− fromYamlScalar = cs . value
192− toYamlScalar b = YamlScalar (cs b) NoTag Any
194−-- | Merge assoc-lists by keys.
195−-- First list overrides second:
196−-- [(k1, x), (k2, y)] `mergeAssocLists` [(k3, z)] == [(k1, x), (k2, y), (k3, z)]
197−-- [(k1, x), (k2, y)] `mergeAssocLists` [(k2, z)] == [(k1, x), (k2, y)]
198−mergeAssocLists :: (Eq k) => [(k, v)] -> [(k, v)] -> [(k, v)]
199−mergeAssocLists a [] = a
200−mergeAssocLists [] b = b
201−mergeAssocLists a ((bk, bv):bs) =
203− Nothing -> (bk, bv) : mergeAssocLists a bs
204− Just av -> (bk, av) : mergeAssocLists (filter (\(x, _) -> x /= bk) a) bs
206−toYamlObject :: IsYamlScalar k
210−toYamlObject = mapKeysValues toYamlScalar toYamlScalar
212−fromYamlObject :: IsYamlScalar k
216−fromYamlObject = mapKeysValues fromYamlScalar fromYamlScalar
218−encode :: (IsYamlScalar k, IsYamlScalar v) => Object k v -> ByteString
44+encode :: ToJSON a => a -> ByteString
219encode obj = unsafePerformIO $
45encode obj = unsafePerformIO $
220− C.runResourceT $ CL.sourceList (objToEvents $ toYamlObject obj)
46+ C.runResourceT $ CL.sourceList (objToEvents $ toJSON obj)
221 C.$$ Y.encode
47 C.$$ Y.encode
223−encodeFile :: (IsYamlScalar k, IsYamlScalar v)
224− => FilePath
49+encodeFile :: ToJSON a => FilePath -> a -> IO ()
227encodeFile fp obj = C.runResourceT
50encodeFile fp obj = C.runResourceT
228− $ CL.sourceList (objToEvents $ toYamlObject obj)
51+ $ CL.sourceList (objToEvents $ toJSON obj)
229 C.$$ Y.encodeFile fp
52 C.$$ Y.encodeFile fp
231−objToEvents :: YamlObject -> [Y.Event]
54+objToEvents :: Value -> [Y.Event]
232objToEvents o = (:) EventStreamStart
55objToEvents o = (:) EventStreamStart
233 . (:) EventDocumentStart
56 . (:) EventDocumentStart
234 $ objToEvents' o
57 $ objToEvents' o
@@ -236,21 +59,24 @@ objToEvents o = (:) EventStreamStart
236 , EventStreamEnd
59 , EventStreamEnd
239scalarToEvent :: YamlScalar -> Event
63scalarToEvent :: YamlScalar -> Event
240scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
64scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
242−objToEvents' :: YamlObject -> [Y.Event] -> [Y.Event]
67+objToEvents' :: Value -> [Y.Event] -> [Y.Event]
243−objToEvents' (Scalar s) rest = scalarToEvent s : rest
68+--objToEvents' (Scalar s) rest = scalarToEvent s : rest
244−objToEvents' (Sequence list) rest =
69+objToEvents' (Array list) rest =
245 EventSequenceStart Nothing
70 EventSequenceStart Nothing
246− : foldr ($) (EventSequenceEnd : rest) (map objToEvents' list)
71+ : foldr ($) (EventSequenceEnd : rest) (map objToEvents' $ V.toList list)
247−objToEvents' (Mapping pairs) rest =
72+objToEvents' (Object pairs) rest =
248 EventMappingStart Nothing
73 EventMappingStart Nothing
249− : foldr ($) (EventMappingEnd : rest) (map pairToEvents pairs)
74+ : foldr ($) (EventMappingEnd : rest) (map pairToEvents $ M.toList pairs)
75+objToEvents' (String s) rest = EventScalar (encodeUtf8 s) StrTag Any Nothing : rest
251−pairToEvents :: (YamlScalar, YamlObject) -> [Y.Event] -> [Y.Event]
77+pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
252pairToEvents (k, v) rest =
78pairToEvents (k, v) rest =
253− scalarToEvent k
79+ EventScalar (encodeUtf8 k) StrTag Any Nothing
254 : objToEvents' v rest
80 : objToEvents' v rest
256-- Parsing
82-- Parsing
@@ -277,7 +103,7 @@ instance MonadTrans PErrorT where
277instance MonadIO m => MonadIO (PErrorT m) where
103instance MonadIO m => MonadIO (PErrorT m) where
278 liftIO = lift . liftIO
104 liftIO = lift . liftIO
280−type Parser = StateT (Map.Map String YamlObject) IO
106+type Parser = StateT (Map.Map String Value) IO
282requireEvent :: Event -> C.Sink Event Parser ()
108requireEvent :: Event -> C.Sink Event Parser ()
283requireEvent e = do
109requireEvent e = do
@@ -286,7 +112,7 @@ requireEvent e = do
286 then return ()
112 then return ()
287 else liftIO $ throwIO $ UnexpectedEvent f $ Just e
113 else liftIO $ throwIO $ UnexpectedEvent f $ Just e
289−parse :: C.Sink Event Parser YamlObject
115+parse :: C.Sink Event Parser Value
290parse = do
116parse = do
291 requireEvent EventStreamStart
117 requireEvent EventStreamStart
292 requireEvent EventDocumentStart
118 requireEvent EventDocumentStart
@@ -295,23 +121,23 @@ parse = do
295 requireEvent EventStreamEnd
121 requireEvent EventStreamEnd
296 return res
122 return res
298−parseScalar :: ByteString -> Tag -> Style -> Anchor
124+parseScalar :: ByteString -> Anchor
299− -> C.Sink Event Parser YamlScalar
125+ -> C.Sink Event Parser Text
300−parseScalar v t s a = do
126+parseScalar v a = do
301− let res = YamlScalar v t s
127+ let res = decodeUtf8With lenientDecode v
302 case a of
128 case a of
303 Nothing -> return res
129 Nothing -> return res
304 Just an -> do
130 Just an -> do
305− lift $ modify (Map.insert an $ Scalar res)
131+ lift $ modify (Map.insert an $ String res)
306 return res
132 return res
308−parseO :: C.Sink Event Parser YamlObject
134+parseO :: C.Sink Event Parser Value
309parseO = do
135parseO = do
310 me <- CL.head
136 me <- CL.head
311 case me of
137 case me of
312− Just (EventScalar v t s a) -> Scalar `liftM` parseScalar v t s a
138+ Just (EventScalar v _t _s a) -> fmap String $ parseScalar v a
313 Just (EventSequenceStart a) -> parseS a id
139 Just (EventSequenceStart a) -> parseS a id
314− Just (EventMappingStart a) -> parseM a id
140+ Just (EventMappingStart a) -> parseM a M.empty
315 Just (EventAlias an) -> do
141 Just (EventAlias an) -> do
316 m <- lift get
142 m <- lift get
317 case Map.lookup an m of
143 case Map.lookup an m of
@@ -320,14 +146,14 @@ parseO = do
320 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
146 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
322parseS :: Y.Anchor
148parseS :: Y.Anchor
323− -> ([YamlObject] -> [YamlObject])
149+ -> ([Value] -> [Value])
324− -> C.Sink Event Parser YamlObject
150+ -> C.Sink Event Parser Value
325parseS a front = do
151parseS a front = do
326 me <- CL.peek
152 me <- CL.peek
327 case me of
153 case me of
328 Just EventSequenceEnd -> do
154 Just EventSequenceEnd -> do
329 CL.drop 1
155 CL.drop 1
330− let res = Sequence $ front []
156+ let res = Array $ V.fromList $ front []
331 case a of
157 case a of
332 Nothing -> return res
158 Nothing -> return res
333 Just an -> do
159 Just an -> do
@@ -338,54 +164,48 @@ parseS a front = do
338 parseS a $ front . (:) o
164 parseS a $ front . (:) o
340parseM :: Y.Anchor
166parseM :: Y.Anchor
341− -> ([(YamlScalar, YamlObject)] -> [(YamlScalar, YamlObject)])
167+ -> M.HashMap Text Value
342− -> C.Sink Event Parser YamlObject
168+ -> C.Sink Event Parser Value
343parseM a front = do
169parseM a front = do
344 me <- CL.peek
170 me <- CL.peek
345 case me of
171 case me of
346 Just EventMappingEnd -> do
172 Just EventMappingEnd -> do
347 CL.drop 1
173 CL.drop 1
348− let res = Mapping $ front []
174+ let res = Object front
349 case a of
175 case a of
350 Nothing -> return res
176 Nothing -> return res
351 Just an -> do
177 Just an -> do
352 lift $ modify $ Map.insert an res
178 lift $ modify $ Map.insert an res
353 return res
179 return res
355− me' <- CL.head
181+ CL.drop 1
356− s <- case me' of
182+ s <- case me of
357− Just (EventScalar v t s a') -> parseScalar v t s a'
183+ Just (EventScalar v _ _ a') -> parseScalar v a'
358− _ -> liftIO $ throwIO $ UnexpectedEvent me' Nothing
184+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
359 o <- parseO
185 o <- parseO
360− let al = mergeAssocLists [(s, o)] $ front []
186+ parseM a $ M.insert s o front
361− al' = if fromYamlScalar s == "<<"
364− Mapping l -> mergeAssocLists al l
365− Sequence l -> mergeAssocLists al $ foldl merge' [] l
367− parseM a (`mergeAssocLists` al')
368− where merge' :: (Eq k) => [(k, Object k v)] -> Object k v -> [(k, Object k v)]
369− merge' al (Mapping om) = mergeAssocLists al om
372−decode :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
188+decode :: FromJSON a
373 => ByteString
189 => ByteString
374− -> m (Object k v)
190+ -> Maybe a
375−decode bs = unsafePerformIO $ decodeHelper (Y.decode bs)
191+decode bs = unsafePerformIO $ fmap (either (const Nothing) id) $ decodeHelper (Y.decode bs)
377−decodeFile :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
193+decodeFile :: FromJSON a
378 => FilePath
194 => FilePath
379− -> IO (m (Object k v))
195+ -> IO (Maybe a)
380−decodeFile fp = decodeHelper (Y.decodeFile fp)
196+decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO return
382−decodeHelper :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
198+decodeHelper :: FromJSON a
383 => C.Source Parser Y.Event
199 => C.Source Parser Y.Event
384− -> IO (m (Object k v))
200+ -> IO (Either ParseException (Maybe a))
385decodeHelper src = do
201decodeHelper src = do
386 x <- try $ flip evalStateT Map.empty $ C.runResourceT $ src C.$$ parse
202 x <- try $ flip evalStateT Map.empty $ C.runResourceT $ src C.$$ parse
387 case x of
203 case x of
389− | Just pe <- fromException e -> return $ failure (pe :: ParseException)
205+ | Just pe <- fromException e -> return $ Left pe
390− | otherwise -> return $ failure $ InvalidYaml $ Just $ show e
206+ | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just $ show (ye :: YamlException)
391− Right y -> return $ return $ fromYamlObject y
207+ | otherwise -> throwIO e
208+ Right y -> return $ Right $ parseMaybe parseJSON y
210+array :: [Value] -> Value
211+array = Array . V.fromList