git.iko.soy/typeable/yaml
on 8381f21 help sign in
typeable/yaml/Data/Yaml.hs
298 lines 10 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE OverloadedStrings #-}
9-- | Provides a high-level interface for processing YAML files.
10--
11-- This module reuses most of the infrastructure from the @aeson@ package.
12-- This means that you can use all of the existing tools for JSON
13-- processing for processing YAML files. As a result, much of the
14-- documentation below mentions JSON; do not let that confuse you, it's
15-- intentional.
16--
17-- For the most part, YAML content translates directly into JSON, and
18-- therefore there is very little data loss. If you need to deal with YAML
19-- more directly (e.g., directly deal with aliases), you should use the
20-- "Text.Libyaml" module instead.
21--
22-- For documentation on the @aeson@ types, functions, classes, and
23-- operators, please see the @Data.Aeson@ module of the @aeson@ package.
24module Data.Yaml
25 ( -- * Types
26 Value (..)
27 , Parser
28 , Object
29 , Array
30 , ParseException(..)
31 -- * Constructors and accessors
32 , object
33 , array
34 , (.=)
35 , (.:)
36 , (.:?)
37 , (.!=)
38 -- * Parsing
39 , parseMonad
40 , parseEither
41 , parseMaybe
42 -- * Classes
43 , ToJSON (..)
44 , FromJSON (..)
45 -- * Encoding/decoding
46 , encode
47 , encodeFile
48 , decode
49 , decodeFile
50 -- ** Better error information
51 , decodeEither
52 -- ** More control over decoding
53 , decodeHelper
54 ) where
56import qualified Text.Libyaml as Y
57import Data.Aeson
58 ( Value (..), ToJSON (..), FromJSON (..), object
59 , (.=) , (.:) , (.:?) , (.!=)
60 , Object, Array
61 )
62import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser)
63import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
64import Data.ByteString (ByteString)
65import qualified Data.ByteString.Char8 as S8
66import qualified Data.Map as Map
67import System.IO.Unsafe (unsafePerformIO)
68import Control.Exception (try, throwIO, fromException, Exception)
69import Control.Monad.Trans.State
70import qualified Data.Conduit as C
71import qualified Data.Conduit.List as CL
72import Control.Monad.Trans.Class (MonadTrans, lift)
73import Control.Monad.IO.Class (MonadIO, liftIO)
74import Control.Monad (liftM)
75import Data.Char (toUpper)
76import qualified Data.Vector as V
77import Data.Text (Text, pack)
78import qualified Data.Text as T
79import Data.Text.Read (signed, decimal, double)
80import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
81import Data.Text.Encoding.Error (lenientDecode)
82import qualified Data.HashMap.Strict as M
83import Data.Typeable
84import Data.Attoparsec.Number
86encode :: ToJSON a => a -> ByteString
87encode obj = unsafePerformIO $
88 C.runResourceT $ CL.sourceList (objToEvents $ toJSON obj)
89 C.$$ Y.encode
91encodeFile :: ToJSON a => FilePath -> a -> IO ()
92encodeFile fp obj = C.runResourceT
93 $ CL.sourceList (objToEvents $ toJSON obj)
94 C.$$ Y.encodeFile fp
96objToEvents :: Value -> [Y.Event]
97objToEvents o = (:) EventStreamStart
98 . (:) EventDocumentStart
99 $ objToEvents' o
100 [ EventDocumentEnd
101 , EventStreamEnd
102 ]
104{- FIXME
105scalarToEvent :: YamlScalar -> Event
106scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
107-}
109objToEvents' :: Value -> [Y.Event] -> [Y.Event]
110--objToEvents' (Scalar s) rest = scalarToEvent s : rest
111objToEvents' (Array list) rest =
112 EventSequenceStart Nothing
113 : foldr ($) (EventSequenceEnd : rest) (map objToEvents' $ V.toList list)
114objToEvents' (Object pairs) rest =
115 EventMappingStart Nothing
116 : foldr ($) (EventMappingEnd : rest) (map pairToEvents $ M.toList pairs)
118-- Empty strings need special handling to ensure they get quoted. This avoids:
119-- https://github.com/snoyberg/yaml/issues/24
120objToEvents' (String "") rest = EventScalar "" NoTag SingleQuoted Nothing : rest
122objToEvents' (String s) rest = EventScalar (encodeUtf8 s) StrTag PlainNoTag Nothing : rest
123objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest
124objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest
125objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest
126objToEvents' (Number n) rest = EventScalar (S8.pack $ show n) IntTag PlainNoTag Nothing : rest
128pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
129pairToEvents (k, v) rest =
130 EventScalar (encodeUtf8 k) StrTag PlainNoTag Nothing
131 : objToEvents' v rest
133-- Parsing
135data ParseException = NonScalarKey
136 | UnknownAlias { _anchorName :: Y.AnchorName }
137 | UnexpectedEvent { _received :: Maybe Event
138 , _expected :: Maybe Event
139 }
140 | InvalidYaml (Maybe YamlException)
141 deriving (Show, Typeable)
142instance Exception ParseException
144newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
145instance Monad m => Monad (PErrorT m) where
146 return = PErrorT . return . Right
147 (PErrorT m) >>= f = PErrorT $ do
148 e <- m
149 case e of
150 Left e' -> return $ Left e'
151 Right a -> runPErrorT $ f a
152instance MonadTrans PErrorT where
153 lift = PErrorT . liftM Right
154instance MonadIO m => MonadIO (PErrorT m) where
155 liftIO = lift . liftIO
157type Parse = StateT (Map.Map String Value) (C.ResourceT IO)
159requireEvent :: Event -> C.Sink Event Parse ()
160requireEvent e = do
161 f <- CL.head
162 if f == Just e
163 then return ()
164 else liftIO $ throwIO $ UnexpectedEvent f $ Just e
166parse :: C.Sink Event Parse Value
167parse = do
168 requireEvent EventStreamStart
169 requireEvent EventDocumentStart
170 res <- parseO
171 requireEvent EventDocumentEnd
172 requireEvent EventStreamEnd
173 return res
175parseScalar :: ByteString -> Anchor -> Style -> Tag
176 -> C.Sink Event Parse Text
177parseScalar v a style tag = do
178 let res = decodeUtf8With lenientDecode v
179 case a of
180 Nothing -> return res
181 Just an -> do
182 lift $ modify (Map.insert an $ textToValue style tag res)
183 return res
185textToValue :: Style -> Tag -> Text -> Value
186textToValue SingleQuoted _ t = String t
187textToValue DoubleQuoted _ t = String t
188textToValue _ StrTag t = String t
189textToValue Folded _ t = String t
190textToValue _ _ t
191 | t `elem` ["null", "Null", "NULL", "~", ""] = Null
192 | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True
193 | any (t `isLike`) ["n", "no", "off", "false"] = Bool False
194 | Right (x, "") <- signed decimal t = Number $ I x
195 | Right (x, "") <- double t = Number $ D x
196 | otherwise = String t
197 where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]
198 where titleCased = toUpper (T.head ref) `T.cons` T.tail ref
201parseO :: C.Sink Event Parse Value
202parseO = do
203 me <- CL.head
204 case me of
205 Just (EventScalar v tag style a) -> fmap (textToValue style tag) $ parseScalar v a style tag
206 Just (EventSequenceStart a) -> parseS a id
207 Just (EventMappingStart a) -> parseM a M.empty
208 Just (EventAlias an) -> do
209 m <- lift get
210 case Map.lookup an m of
211 Nothing -> liftIO $ throwIO $ UnknownAlias an
212 Just v -> return v
213 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
215parseS :: Y.Anchor
216 -> ([Value] -> [Value])
217 -> C.Sink Event Parse Value
218parseS a front = do
219 me <- CL.peek
220 case me of
221 Just EventSequenceEnd -> do
222 CL.drop 1
223 let res = Array $ V.fromList $ front []
224 case a of
225 Nothing -> return res
226 Just an -> do
227 lift $ modify $ Map.insert an res
228 return res
229 _ -> do
230 o <- parseO
231 parseS a $ front . (:) o
233parseM :: Y.Anchor
234 -> M.HashMap Text Value
235 -> C.Sink Event Parse Value
236parseM a front = do
237 me <- CL.peek
238 case me of
239 Just EventMappingEnd -> do
240 CL.drop 1
241 let res = Object front
242 case a of
243 Nothing -> return res
244 Just an -> do
245 lift $ modify $ Map.insert an res
246 return res
247 _ -> do
248 CL.drop 1
249 s <- case me of
250 Just (EventScalar v tag style a') -> parseScalar v a' style tag
251 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
252 o <- parseO
254 let al = M.insert s o front
255 al' = if s == pack "<<"
256 then case o of
257 Object l -> M.union al l
258 Array l -> M.union al $ foldl merge' M.empty $ V.toList l
259 _ -> al
260 else al
261 parseM a $ M.insert s o al'
262 where merge' al (Object om) = M.union al om
263 merge' al _ = al
265decode :: FromJSON a
266 => ByteString
267 -> Maybe a
268decode bs = unsafePerformIO
269 $ fmap (either (const Nothing) (either (const Nothing) Just))
270 $ decodeHelper (Y.decode bs)
272decodeFile :: FromJSON a
273 => FilePath
274 -> IO (Maybe a)
275decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO (return . either (const Nothing) id)
277decodeEither :: FromJSON a => ByteString -> Either String a
278decodeEither bs = unsafePerformIO
279 $ fmap (either (Left . show) id)
280 $ decodeHelper (Y.decode bs)
282decodeHelper :: FromJSON a
283 => C.Source Parse Y.Event
284 -> IO (Either ParseException (Either String a))
285decodeHelper src = do
286 x <- try $ C.runResourceT $ flip evalStateT Map.empty $ src C.$$ parse
287 case x of
288 Left e
289 | Just pe <- fromException e -> return $ Left pe
290 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
291 | otherwise -> throwIO e
292 Right y -> return $ Right $ parseEither parseJSON y
294array :: [Value] -> Value
295array = Array . V.fromList
297parseMonad :: Monad m => (a -> Parser b) -> a -> m b
298parseMonad p = either fail return . parseEither p