@@ -3,232 +3,55 @@
33{-# LANGUAGE CPP #-}
44{-# LANGUAGE DeriveDataTypeable #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE PackageImports #-}
76{-# LANGUAGE PatternGuards #-}
8−{-|
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:
12−
13−@
14− data Object k v = Scalar v
15− | Sequence [Object k v]
16− | Mapping [(k, Object k v)]
17−@
18−
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.
22−
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
25− by default.
26−
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,
31−lazy\/string Text).
32−
33−/YamlScalar and YamlObject/
34−
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.
38−
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.
44−
45−/Encoding and decoding/
46−
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:
51−
52−@
53− encodeFile "myfile.yaml" $ Mapping
54− [ ("Michael", Mapping
55− [ ("age", Scalar "26")
56− , ("color", Scalar "blue")
57− ])
58− , ("Eliezer", Mapping
59− [ ("age", Scalar "2")
60− , ("color", Scalar "green")
61− ])
62− ]
63−@
64−
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
67−could use:
68−
69−@
70− maybeObject <- decodeFile "myfile.yaml"
71− case maybeObject of
72− Nothing -> putStrLn "Error parsing YAML file."
73− Just object -> putStrLn "Successfully parsed."
74−@
75−
76−If you just want to throw any parse errors as IO exception, you can use join:
77−
78−@
79− import Control.Monad (join)
80− object <- join $ decodeFile "myfile.yaml"
81−@
82−
83−This takes advantage of the IO instance of Failure.
84−
85−/Parsing an Object/
86−
87−In order to pull the data out of an Object, you can use the helper functions
88−from Data.Object. For example:
89−
90−@
91− import Data.Object
92− import Data.Object.Yaml
93− import Control.Monad
94−
95− main = do
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."
101−@
102−
103−lookupScalar and friends implement Maybe, so you can test for optional
104−attributes by switching on Nothing/Just a:
105−
106−@
107− name <- lookupScalar "middleName" michael :: Maybe String
108−@
109−
110−
111−/And that's it/
112−
113−There's really not more to know about this library. Enjoy!
114−-}
7+{-# LANGUAGE ScopedTypeVariables #-}
1158module Data.Yaml
116− ( -- * Definition of 'YamlObject'
117− YamlScalar (..)
118− , YamlObject
119− -- * Automatic scalar conversions
120− , IsYamlScalar (..)
121− , toYamlObject
122− , fromYamlObject
9+ ( -- * Types
10+ Value (..)
11+ , object
12+ , array
13+ -- * Classes
14+ , ToJSON (..)
15+ , FromJSON (..)
12316 -- * Encoding/decoding
12417 , encode
12518 , encodeFile
12619 , decode
12720 , decodeFile
128− -- * Exceptions
129− , ParseException (..)
13021 ) where
13122
13223import qualified Text.Libyaml as Y
24+import Data.Aeson (Value (..), ToJSON (..), FromJSON (..), object)
25+import Data.Aeson.Types (Pair, parseMaybe)
13326import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
134−import Data.Object
13527import Data.ByteString (ByteString)
13628import qualified Data.Map as Map
13729import System.IO.Unsafe (unsafePerformIO)
138−import Control.Failure (Failure (failure))
139−
140−import qualified Data.Text
141−import qualified Data.Text.Lazy
142−import qualified Data.ByteString
143−import qualified Data.ByteString.Lazy
144−
145−import Data.Convertible.Text (cs)
146−import Data.Data
147−
148−import Control.Monad.Trans.Class
149−import Control.Monad.IO.Class
30+import Control.Exception (try, throwIO, fromException, Exception)
15031import Control.Monad.Trans.State
151−import Control.Monad
15232import qualified Data.Conduit as C
15333import qualified Data.Conduit.List as CL
154−import Prelude hiding (catch)
155−import Control.Exception (throwIO, Exception, fromException, try)
156−import Data.String (IsString (fromString))
157−
158−-- | Equality depends on 'value' and 'tag', not 'style'.
159−data YamlScalar = YamlScalar
160− { value :: ByteString
161− , tag :: Tag
162− , style :: Style
163− }
164− deriving (Show, Read, Data, Typeable)
165−instance Eq YamlScalar where
166− (YamlScalar v t _) == (YamlScalar v' t' _) = v == v' && t == t'
167−instance IsString YamlScalar where
168− fromString = toYamlScalar
169−
170−type YamlObject = Object YamlScalar YamlScalar
171−
172−class (Eq a) => IsYamlScalar a where
173− fromYamlScalar :: YamlScalar -> a
174− toYamlScalar :: a -> YamlScalar
175−instance IsYamlScalar YamlScalar where
176− fromYamlScalar = id
177− toYamlScalar = id
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
193−
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) =
202− case lookup bk a of
203− Nothing -> (bk, bv) : mergeAssocLists a bs
204− Just av -> (bk, av) : mergeAssocLists (filter (\(x, _) -> x /= bk) a) bs
205−
206−toYamlObject :: IsYamlScalar k
207− => IsYamlScalar v
208− => Object k v
209− -> YamlObject
210−toYamlObject = mapKeysValues toYamlScalar toYamlScalar
211−
212−fromYamlObject :: IsYamlScalar k
213− => IsYamlScalar v
214− => YamlObject
215− -> Object k v
216−fromYamlObject = mapKeysValues fromYamlScalar fromYamlScalar
217−
218−encode :: (IsYamlScalar k, IsYamlScalar v) => Object k v -> ByteString
34+import Control.Monad.Trans.Class (MonadTrans, lift)
35+import Control.Monad.IO.Class (MonadIO, liftIO)
36+import Control.Monad (liftM)
37+import qualified Data.Vector as V
38+import Data.Text (Text)
39+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
40+import Data.Text.Encoding.Error (lenientDecode)
41+import qualified Data.HashMap.Strict as M
42+import Data.Typeable
43+
44+encode :: ToJSON a => a -> ByteString
21945encode obj = unsafePerformIO $
220− C.runResourceT $ CL.sourceList (objToEvents $ toYamlObject obj)
46+ C.runResourceT $ CL.sourceList (objToEvents $ toJSON obj)
22147 C.$$ Y.encode
22248
223−encodeFile :: (IsYamlScalar k, IsYamlScalar v)
224− => FilePath
225− -> Object k v
226− -> IO ()
49+encodeFile :: ToJSON a => FilePath -> a -> IO ()
22750encodeFile fp obj = C.runResourceT
228− $ CL.sourceList (objToEvents $ toYamlObject obj)
51+ $ CL.sourceList (objToEvents $ toJSON obj)
22952 C.$$ Y.encodeFile fp
23053
231−objToEvents :: YamlObject -> [Y.Event]
54+objToEvents :: Value -> [Y.Event]
23255objToEvents o = (:) EventStreamStart
23356 . (:) EventDocumentStart
23457 $ objToEvents' o
@@ -236,21 +59,24 @@ objToEvents o = (:) EventStreamStart
23659 , EventStreamEnd
23760 ]
23861
62+{- FIXME
23963scalarToEvent :: YamlScalar -> Event
24064scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
65+-}
24166
242−objToEvents' :: YamlObject -> [Y.Event] -> [Y.Event]
243−objToEvents' (Scalar s) rest = scalarToEvent s : rest
244−objToEvents' (Sequence list) rest =
67+objToEvents' :: Value -> [Y.Event] -> [Y.Event]
68+--objToEvents' (Scalar s) rest = scalarToEvent s : rest
69+objToEvents' (Array list) rest =
24570 EventSequenceStart Nothing
246− : foldr ($) (EventSequenceEnd : rest) (map objToEvents' list)
247−objToEvents' (Mapping pairs) rest =
71+ : foldr ($) (EventSequenceEnd : rest) (map objToEvents' $ V.toList list)
72+objToEvents' (Object pairs) rest =
24873 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
25076
251−pairToEvents :: (YamlScalar, YamlObject) -> [Y.Event] -> [Y.Event]
77+pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
25278pairToEvents (k, v) rest =
253− scalarToEvent k
79+ EventScalar (encodeUtf8 k) StrTag Any Nothing
25480 : objToEvents' v rest
25581
25682-- Parsing
@@ -277,7 +103,7 @@ instance MonadTrans PErrorT where
277103instance MonadIO m => MonadIO (PErrorT m) where
278104 liftIO = lift . liftIO
279105
280−type Parser = StateT (Map.Map String YamlObject) IO
106+type Parser = StateT (Map.Map String Value) IO
281107
282108requireEvent :: Event -> C.Sink Event Parser ()
283109requireEvent e = do
@@ -286,7 +112,7 @@ requireEvent e = do
286112 then return ()
287113 else liftIO $ throwIO $ UnexpectedEvent f $ Just e
288114
289−parse :: C.Sink Event Parser YamlObject
115+parse :: C.Sink Event Parser Value
290116parse = do
291117 requireEvent EventStreamStart
292118 requireEvent EventDocumentStart
@@ -295,23 +121,23 @@ parse = do
295121 requireEvent EventStreamEnd
296122 return res
297123
298−parseScalar :: ByteString -> Tag -> Style -> Anchor
299− -> C.Sink Event Parser YamlScalar
300−parseScalar v t s a = do
301− let res = YamlScalar v t s
124+parseScalar :: ByteString -> Anchor
125+ -> C.Sink Event Parser Text
126+parseScalar v a = do
127+ let res = decodeUtf8With lenientDecode v
302128 case a of
303129 Nothing -> return res
304130 Just an -> do
305− lift $ modify (Map.insert an $ Scalar res)
131+ lift $ modify (Map.insert an $ String res)
306132 return res
307133
308−parseO :: C.Sink Event Parser YamlObject
134+parseO :: C.Sink Event Parser Value
309135parseO = do
310136 me <- CL.head
311137 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
313139 Just (EventSequenceStart a) -> parseS a id
314− Just (EventMappingStart a) -> parseM a id
140+ Just (EventMappingStart a) -> parseM a M.empty
315141 Just (EventAlias an) -> do
316142 m <- lift get
317143 case Map.lookup an m of
@@ -320,14 +146,14 @@ parseO = do
320146 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
321147
322148parseS :: Y.Anchor
323− -> ([YamlObject] -> [YamlObject])
324− -> C.Sink Event Parser YamlObject
149+ -> ([Value] -> [Value])
150+ -> C.Sink Event Parser Value
325151parseS a front = do
326152 me <- CL.peek
327153 case me of
328154 Just EventSequenceEnd -> do
329155 CL.drop 1
330− let res = Sequence $ front []
156+ let res = Array $ V.fromList $ front []
331157 case a of
332158 Nothing -> return res
333159 Just an -> do
@@ -338,54 +164,48 @@ parseS a front = do
338164 parseS a $ front . (:) o
339165
340166parseM :: Y.Anchor
341− -> ([(YamlScalar, YamlObject)] -> [(YamlScalar, YamlObject)])
342− -> C.Sink Event Parser YamlObject
167+ -> M.HashMap Text Value
168+ -> C.Sink Event Parser Value
343169parseM a front = do
344170 me <- CL.peek
345171 case me of
346172 Just EventMappingEnd -> do
347173 CL.drop 1
348− let res = Mapping $ front []
174+ let res = Object front
349175 case a of
350176 Nothing -> return res
351177 Just an -> do
352178 lift $ modify $ Map.insert an res
353179 return res
354180 _ -> do
355− me' <- CL.head
356− s <- case me' of
357− Just (EventScalar v t s a') -> parseScalar v t s a'
358− _ -> liftIO $ throwIO $ UnexpectedEvent me' Nothing
181+ CL.drop 1
182+ s <- case me of
183+ Just (EventScalar v _ _ a') -> parseScalar v a'
184+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
359185 o <- parseO
360− let al = mergeAssocLists [(s, o)] $ front []
361− al' = if fromYamlScalar s == "<<"
362− then case o of
363− Scalar _ -> al
364− Mapping l -> mergeAssocLists al l
365− Sequence l -> mergeAssocLists al $ foldl merge' [] l
366− else al
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
370− merge' al _ = al
186+ parseM a $ M.insert s o front
371187
372−decode :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
188+decode :: FromJSON a
373189 => ByteString
374− -> m (Object k v)
375−decode bs = unsafePerformIO $ decodeHelper (Y.decode bs)
190+ -> Maybe a
191+decode bs = unsafePerformIO $ fmap (either (const Nothing) id) $ decodeHelper (Y.decode bs)
376192
377−decodeFile :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
193+decodeFile :: FromJSON a
378194 => FilePath
379− -> IO (m (Object k v))
380−decodeFile fp = decodeHelper (Y.decodeFile fp)
195+ -> IO (Maybe a)
196+decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO return
381197
382−decodeHelper :: (Failure ParseException m, IsYamlScalar k, IsYamlScalar v)
198+decodeHelper :: FromJSON a
383199 => C.Source Parser Y.Event
384− -> IO (m (Object k v))
200+ -> IO (Either ParseException (Maybe a))
385201decodeHelper src = do
386202 x <- try $ flip evalStateT Map.empty $ C.runResourceT $ src C.$$ parse
387203 case x of
388204 Left e
389− | Just pe <- fromException e -> return $ failure (pe :: ParseException)
390− | otherwise -> return $ failure $ InvalidYaml $ Just $ show e
391− Right y -> return $ return $ fromYamlObject y
205+ | Just pe <- fromException e -> return $ Left pe
206+ | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just $ show (ye :: YamlException)
207+ | otherwise -> throwIO e
208+ Right y -> return $ Right $ parseMaybe parseJSON y
209+
210+array :: [Value] -> Value
211+array = Array . V.fromList