git.iko.soy/typeable/yaml
on 90dd080 help sign in
typeable/yaml/Data/Yaml.hs
227 lines 7.6 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 #-}
9module Data.Yaml
10 ( -- * Types
11 Value (..)
12 , object
13 , array
14 -- * Classes
15 , ToJSON (..)
16 , FromJSON (..)
17 -- * Encoding/decoding
18 , encode
19 , encodeFile
20 , decode
21 , decodeFile
22 ) where
24import qualified Text.Libyaml as Y
25import Data.Aeson (Value (..), ToJSON (..), FromJSON (..), object)
26import Data.Aeson.Types (Pair, parseMaybe)
27import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
28import Data.ByteString (ByteString)
29import qualified Data.ByteString.Char8 as S8
30import qualified Data.Map as Map
31import System.IO.Unsafe (unsafePerformIO)
32import Control.Exception (try, throwIO, fromException, Exception)
33import Control.Monad.Trans.State
34import qualified Data.Conduit as C
35import qualified Data.Conduit.List as CL
36import Control.Monad.Trans.Class (MonadTrans, lift)
37import Control.Monad.IO.Class (MonadIO, liftIO)
38import Control.Monad (liftM)
39import qualified Data.Vector as V
40import Data.Text (Text, pack)
41import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
42import Data.Text.Encoding.Error (lenientDecode)
43import qualified Data.HashMap.Strict as M
44import Data.Typeable
46encode :: ToJSON a => a -> ByteString
47encode obj = unsafePerformIO $
48 C.runResourceT $ CL.sourceList (objToEvents $ toJSON obj)
49 C.$$ Y.encode
51encodeFile :: ToJSON a => FilePath -> a -> IO ()
52encodeFile fp obj = C.runResourceT
53 $ CL.sourceList (objToEvents $ toJSON obj)
54 C.$$ Y.encodeFile fp
56objToEvents :: Value -> [Y.Event]
57objToEvents o = (:) EventStreamStart
58 . (:) EventDocumentStart
59 $ objToEvents' o
60 [ EventDocumentEnd
61 , EventStreamEnd
62 ]
64{- FIXME
65scalarToEvent :: YamlScalar -> Event
66scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
67-}
69objToEvents' :: Value -> [Y.Event] -> [Y.Event]
70--objToEvents' (Scalar s) rest = scalarToEvent s : rest
71objToEvents' (Array list) rest =
72 EventSequenceStart Nothing
73 : foldr ($) (EventSequenceEnd : rest) (map objToEvents' $ V.toList list)
74objToEvents' (Object pairs) rest =
75 EventMappingStart Nothing
76 : foldr ($) (EventMappingEnd : rest) (map pairToEvents $ M.toList pairs)
77objToEvents' (String s) rest = EventScalar (encodeUtf8 s) NoTag Any Nothing : rest
78objToEvents' Null rest = EventScalar "null" NoTag Literal Nothing : rest
79objToEvents' (Bool True) rest = EventScalar "true" NoTag Literal Nothing : rest
80objToEvents' (Bool False) rest = EventScalar "false" NoTag Literal Nothing : rest
81objToEvents' (Number n) rest = EventScalar (S8.pack $ show n) NoTag Literal Nothing : rest
83pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
84pairToEvents (k, v) rest =
85 EventScalar (encodeUtf8 k) NoTag Any Nothing
86 : objToEvents' v rest
88-- Parsing
90data ParseException = NonScalarKey
91 | UnknownAlias { _anchorName :: Y.AnchorName }
92 | UnexpectedEvent { _received :: Maybe Event
93 , _expected :: Maybe Event
94 }
95 | InvalidYaml (Maybe String)
96 deriving (Show, Typeable)
97instance Exception ParseException
99newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
100instance Monad m => Monad (PErrorT m) where
101 return = PErrorT . return . Right
102 (PErrorT m) >>= f = PErrorT $ do
103 e <- m
104 case e of
105 Left e' -> return $ Left e'
106 Right a -> runPErrorT $ f a
107instance MonadTrans PErrorT where
108 lift = PErrorT . liftM Right
109instance MonadIO m => MonadIO (PErrorT m) where
110 liftIO = lift . liftIO
112type Parser = StateT (Map.Map String Value) IO
114requireEvent :: Event -> C.Sink Event Parser ()
115requireEvent e = do
116 f <- CL.head
117 if f == Just e
118 then return ()
119 else liftIO $ throwIO $ UnexpectedEvent f $ Just e
121parse :: C.Sink Event Parser Value
122parse = do
123 requireEvent EventStreamStart
124 requireEvent EventDocumentStart
125 res <- parseO
126 requireEvent EventDocumentEnd
127 requireEvent EventStreamEnd
128 return res
130parseScalar :: ByteString -> Anchor
131 -> C.Sink Event Parser Text
132parseScalar v a = do
133 let res = decodeUtf8With lenientDecode v
134 case a of
135 Nothing -> return res
136 Just an -> do
137 lift $ modify (Map.insert an $ String res)
138 return res
140parseO :: C.Sink Event Parser Value
141parseO = do
142 me <- CL.head
143 case me of
144 Just (EventScalar v _t _s a) -> fmap String $ parseScalar v a
145 Just (EventSequenceStart a) -> parseS a id
146 Just (EventMappingStart a) -> parseM a M.empty
147 Just (EventAlias an) -> do
148 m <- lift get
149 case Map.lookup an m of
150 Nothing -> liftIO $ throwIO $ UnknownAlias an
151 Just v -> return v
152 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
154parseS :: Y.Anchor
155 -> ([Value] -> [Value])
156 -> C.Sink Event Parser Value
157parseS a front = do
158 me <- CL.peek
159 case me of
160 Just EventSequenceEnd -> do
161 CL.drop 1
162 let res = Array $ V.fromList $ front []
163 case a of
164 Nothing -> return res
165 Just an -> do
166 lift $ modify $ Map.insert an res
167 return res
168 _ -> do
169 o <- parseO
170 parseS a $ front . (:) o
172parseM :: Y.Anchor
173 -> M.HashMap Text Value
174 -> C.Sink Event Parser Value
175parseM a front = do
176 me <- CL.peek
177 case me of
178 Just EventMappingEnd -> do
179 CL.drop 1
180 let res = Object front
181 case a of
182 Nothing -> return res
183 Just an -> do
184 lift $ modify $ Map.insert an res
185 return res
186 _ -> do
187 CL.drop 1
188 s <- case me of
189 Just (EventScalar v _ _ a') -> parseScalar v a'
190 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
191 o <- parseO
193 let al = M.insert s o front
194 al' = if s == pack "<<"
195 then case o of
196 Object l -> M.union al l
197 Array l -> M.union al $ foldl merge' M.empty $ V.toList l
198 _ -> al
199 else al
200 parseM a $ M.insert s o al'
201 where merge' al (Object om) = M.union al om
202 merge' al _ = al
204decode :: FromJSON a
205 => ByteString
206 -> Maybe a
207decode bs = unsafePerformIO $ fmap (either (const Nothing) id) $ decodeHelper (Y.decode bs)
209decodeFile :: FromJSON a
210 => FilePath
211 -> IO (Maybe a)
212decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO return
214decodeHelper :: FromJSON a
215 => C.Source Parser Y.Event
216 -> IO (Either ParseException (Maybe a))
217decodeHelper src = do
218 x <- try $ flip evalStateT Map.empty $ C.runResourceT $ src C.$$ parse
219 case x of
220 Left e
221 | Just pe <- fromException e -> return $ Left pe
222 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just $ show (ye :: YamlException)
223 | otherwise -> throwIO e
224 Right y -> return $ Right $ parseMaybe parseJSON y
226array :: [Value] -> Value
227array = Array . V.fromList