git.iko.soy/typeable/yaml
on master help sign in
move parsing functions to Data.Yaml.Internal
5b9cc0aSönke Hahn
Data/Yaml.hs+6−182
compare with master
unifiedsplit
@@ -1,8 +1,4 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveDataTypeable #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE PatternGuards #-}
2{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE ScopedTypeVariables #-}
3{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -68,35 +64,27 @@ import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
68import Data.ByteString (ByteString)
64import Data.ByteString (ByteString)
69import qualified Data.Map as Map
65import qualified Data.Map as Map
70import System.IO.Unsafe (unsafePerformIO)
66import System.IO.Unsafe (unsafePerformIO)
71−import Control.Exception (try, throwIO, fromException, Exception, SomeException, AsyncException)
67+import Control.Exception (try, throwIO, fromException, AsyncException)
72import Control.Monad.Trans.State
68import Control.Monad.Trans.State
73import qualified Data.Conduit as C
69import qualified Data.Conduit as C
74import qualified Data.Conduit.List as CL
70import qualified Data.Conduit.List as CL
75−import Control.Monad.Trans.Class (MonadTrans, lift)
76−import Control.Monad.IO.Class (MonadIO, liftIO)
77−import Control.Monad (liftM, ap)
78−import Control.Applicative (Applicative(..))
79−import Data.Char (toUpper)
80import qualified Data.Vector as V
71import qualified Data.Vector as V
81−import Data.Text (Text, pack)
72+import Data.Text (Text)
82import qualified Data.Text as T
73import qualified Data.Text as T
83−import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
74+import Data.Text.Encoding (encodeUtf8)
84−import Data.Text.Encoding.Error (lenientDecode)
85import qualified Data.HashMap.Strict as M
75import qualified Data.HashMap.Strict as M
86−import Data.Typeable
87import qualified Data.HashSet as HashSet
76import qualified Data.HashSet as HashSet
88−import Data.Text.Read
89#if MIN_VERSION_aeson(0, 7, 0)
77#if MIN_VERSION_aeson(0, 7, 0)
90−import Data.Scientific (fromFloatDigits)
91import qualified Data.Text.Encoding as TE
78import qualified Data.Text.Encoding as TE
92import qualified Data.Text.Lazy as TL
79import qualified Data.Text.Lazy as TL
93import Data.Text.Lazy.Builder (toLazyText)
80import Data.Text.Lazy.Builder (toLazyText)
94import Data.Aeson.Encode (encodeToTextBuilder)
81import Data.Aeson.Encode (encodeToTextBuilder)
95#else
82#else
96−import Data.Attoparsec.Number
97import qualified Data.ByteString.Char8 as S8
83import qualified Data.ByteString.Char8 as S8
98#endif
84#endif
99−import Control.Monad.Trans.Resource (ResourceT, runResourceT)
85+import Control.Monad.Trans.Resource (runResourceT)
86+
87+import Data.Yaml.Internal
100
88
101encode :: ToJSON a => a -> ByteString
89encode :: ToJSON a => a -> ByteString
102encode obj = unsafePerformIO $
90encode obj = unsafePerformIO $
@@ -172,158 +160,6 @@ isNumeric =
172 || c == '.'
160 || c == '.'
173 || c == '-'
161 || c == '-'
174
162
175−-- Parsing
176−
177−data ParseException = NonScalarKey
178− | UnknownAlias { _anchorName :: Y.AnchorName }
179− | UnexpectedEvent { _received :: Maybe Event
180− , _expected :: Maybe Event
181− }
182− | InvalidYaml (Maybe YamlException)
183− | AesonException String
184− | OtherParseException SomeException
185− | NonStringKeyAlias Y.AnchorName Value
186− | CyclicIncludes
187− deriving (Show, Typeable)
188−instance Exception ParseException
189−
190−newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
191−instance Monad m => Functor (PErrorT m) where
192− fmap = liftM
193−instance Monad m => Applicative (PErrorT m) where
194− pure = return
195− (<*>) = ap
196−instance Monad m => Monad (PErrorT m) where
197− return = PErrorT . return . Right
198− (PErrorT m) >>= f = PErrorT $ do
199− e <- m
200− case e of
201− Left e' -> return $ Left e'
202− Right a -> runPErrorT $ f a
203−instance MonadTrans PErrorT where
204− lift = PErrorT . liftM Right
205−instance MonadIO m => MonadIO (PErrorT m) where
206− liftIO = lift . liftIO
207−
208−type Parse = StateT (Map.Map String Value) (ResourceT IO)
209−
210−requireEvent :: Event -> C.Sink Event Parse ()
211−requireEvent e = do
212− f <- CL.head
213− if f == Just e
214− then return ()
215− else liftIO $ throwIO $ UnexpectedEvent f $ Just e
216−
217−parse :: C.Sink Event Parse Value
218−parse = do
219− requireEvent EventStreamStart
220− requireEvent EventDocumentStart
221− res <- parseO
222− requireEvent EventDocumentEnd
223− requireEvent EventStreamEnd
224− return res
225−
226−parseScalar :: ByteString -> Anchor -> Style -> Tag
227− -> C.Sink Event Parse Text
228−parseScalar v a style tag = do
229− let res = decodeUtf8With lenientDecode v
230− case a of
231− Nothing -> return res
232− Just an -> do
233− lift $ modify (Map.insert an $ textToValue style tag res)
234− return res
235−
236−textToValue :: Style -> Tag -> Text -> Value
237−textToValue SingleQuoted _ t = String t
238−textToValue DoubleQuoted _ t = String t
239−textToValue _ StrTag t = String t
240−textToValue Folded _ t = String t
241−textToValue _ _ t
242− | t `elem` ["null", "Null", "NULL", "~", ""] = Null
243− | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True
244− | any (t `isLike`) ["n", "no", "off", "false"] = Bool False
245−#if MIN_VERSION_aeson(0, 7, 0)
246− | Right (x, "") <- signed decimal t = Number $ fromIntegral (x :: Integer)
247− | Right (x, "") <- double t = Number $ fromFloatDigits x
248−#else
249− | Right (x, "") <- signed decimal t = Number $ I x
250− | Right (x, "") <- double t = Number $ D x
251−#endif
252− | otherwise = String t
253− where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]
254− where titleCased = toUpper (T.head ref) `T.cons` T.tail ref
255−
256−
257−parseO :: C.Sink Event Parse Value
258−parseO = do
259− me <- CL.head
260− case me of
261− Just (EventScalar v tag style a) -> fmap (textToValue style tag) $ parseScalar v a style tag
262− Just (EventSequenceStart a) -> parseS a id
263− Just (EventMappingStart a) -> parseM a M.empty
264− Just (EventAlias an) -> do
265− m <- lift get
266− case Map.lookup an m of
267− Nothing -> liftIO $ throwIO $ UnknownAlias an
268− Just v -> return v
269− _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
270−
271−parseS :: Y.Anchor
272− -> ([Value] -> [Value])
273− -> C.Sink Event Parse Value
274−parseS a front = do
275− me <- CL.peek
276− case me of
277− Just EventSequenceEnd -> do
278− CL.drop 1
279− let res = Array $ V.fromList $ front []
280− case a of
281− Nothing -> return res
282− Just an -> do
283− lift $ modify $ Map.insert an res
284− return res
285− _ -> do
286− o <- parseO
287− parseS a $ front . (:) o
288−
289−parseM :: Y.Anchor
290− -> M.HashMap Text Value
291− -> C.Sink Event Parse Value
292−parseM a front = do
293− me <- CL.peek
294− case me of
295− Just EventMappingEnd -> do
296− CL.drop 1
297− let res = Object front
298− case a of
299− Nothing -> return res
300− Just an -> do
301− lift $ modify $ Map.insert an res
302− return res
303− _ -> do
304− CL.drop 1
305− s <- case me of
306− Just (EventScalar v tag style a') -> parseScalar v a' style tag
307− Just (EventAlias an) -> do
308− m <- lift get
309− case Map.lookup an m of
310− Nothing -> liftIO $ throwIO $ UnknownAlias an
311− Just (String t) -> return t
312− Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
313− _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
314− o <- parseO
315−
316− let al = M.insert s o front
317− al' = if s == pack "<<"
318− then case o of
319− Object l -> M.union front l
320− Array l -> M.union front $ foldl merge' M.empty $ V.toList l
321− _ -> al
322− else al
323− parseM a al'
324− where merge' al (Object om) = M.union al om
325− merge' al _ = al
326−
327decode :: FromJSON a
163decode :: FromJSON a
328 => ByteString
164 => ByteString
329 -> Maybe a
165 -> Maybe a
@@ -376,18 +212,6 @@ decodeEither' = either Left (either (Left . AesonException) Right)
376 . decodeHelper
212 . decodeHelper
377 . Y.decode
213 . Y.decode
378
214
379−decodeHelper :: FromJSON a
380− => C.Source Parse Y.Event
381− -> IO (Either ParseException (Either String a))
382−decodeHelper src = do
383− x <- try $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse
384− case x of
385− Left e
386− | Just pe <- fromException e -> return $ Left pe
387− | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
388− | otherwise -> throwIO e
389− Right y -> return $ Right $ parseEither parseJSON y
390−
391array :: [Value] -> Value
215array :: [Value] -> Value
392array = Array . V.fromList
216array = Array . V.fromList
393
217
Data/Yaml/Internal.hsnew file+202
@@ -0,0 +1,202 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE PatternGuards #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+module Data.Yaml.Internal
6+ (
7+ ParseException(..)
8+ , parse
9+ , decodeHelper
10+ ) where
11+
12+import qualified Text.Libyaml as Y
13+import Data.Aeson
14+import Data.Aeson.Types hiding (parse)
15+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
16+import Data.ByteString (ByteString)
17+import qualified Data.Map as Map
18+import Control.Exception
19+import Control.Monad.Trans.State
20+import qualified Data.Conduit as C
21+import qualified Data.Conduit.List as CL
22+import Control.Monad.Trans.Class (MonadTrans, lift)
23+import Control.Monad.IO.Class (MonadIO, liftIO)
24+import Control.Monad (liftM, ap)
25+import Control.Applicative (Applicative(..))
26+import Data.Char (toUpper)
27+import qualified Data.Vector as V
28+import Data.Text (Text, pack)
29+import qualified Data.Text as T
30+import Data.Text.Encoding (decodeUtf8With)
31+import Data.Text.Encoding.Error (lenientDecode)
32+import qualified Data.HashMap.Strict as M
33+import Data.Typeable
34+import Data.Text.Read
35+#if MIN_VERSION_aeson(0, 7, 0)
36+import Data.Scientific (fromFloatDigits)
37+#else
38+import Data.Attoparsec.Number
39+#endif
40+import Control.Monad.Trans.Resource (ResourceT, runResourceT)
41+
42+data ParseException = NonScalarKey
43+ | UnknownAlias { _anchorName :: Y.AnchorName }
44+ | UnexpectedEvent { _received :: Maybe Event
45+ , _expected :: Maybe Event
46+ }
47+ | InvalidYaml (Maybe YamlException)
48+ | AesonException String
49+ | OtherParseException SomeException
50+ | NonStringKeyAlias Y.AnchorName Value
51+ | CyclicIncludes
52+ deriving (Show, Typeable)
53+instance Exception ParseException
54+
55+newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
56+instance Monad m => Functor (PErrorT m) where
57+ fmap = liftM
58+instance Monad m => Applicative (PErrorT m) where
59+ pure = return
60+ (<*>) = ap
61+instance Monad m => Monad (PErrorT m) where
62+ return = PErrorT . return . Right
63+ (PErrorT m) >>= f = PErrorT $ do
64+ e <- m
65+ case e of
66+ Left e' -> return $ Left e'
67+ Right a -> runPErrorT $ f a
68+instance MonadTrans PErrorT where
69+ lift = PErrorT . liftM Right
70+instance MonadIO m => MonadIO (PErrorT m) where
71+ liftIO = lift . liftIO
72+
73+type Parse = StateT (Map.Map String Value) (ResourceT IO)
74+
75+requireEvent :: Event -> C.Sink Event Parse ()
76+requireEvent e = do
77+ f <- CL.head
78+ if f == Just e
79+ then return ()
80+ else liftIO $ throwIO $ UnexpectedEvent f $ Just e
81+
82+parse :: C.Sink Event Parse Value
83+parse = do
84+ requireEvent EventStreamStart
85+ requireEvent EventDocumentStart
86+ res <- parseO
87+ requireEvent EventDocumentEnd
88+ requireEvent EventStreamEnd
89+ return res
90+
91+parseScalar :: ByteString -> Anchor -> Style -> Tag
92+ -> C.Sink Event Parse Text
93+parseScalar v a style tag = do
94+ let res = decodeUtf8With lenientDecode v
95+ case a of
96+ Nothing -> return res
97+ Just an -> do
98+ lift $ modify (Map.insert an $ textToValue style tag res)
99+ return res
100+
101+textToValue :: Style -> Tag -> Text -> Value
102+textToValue SingleQuoted _ t = String t
103+textToValue DoubleQuoted _ t = String t
104+textToValue _ StrTag t = String t
105+textToValue Folded _ t = String t
106+textToValue _ _ t
107+ | t `elem` ["null", "Null", "NULL", "~", ""] = Null
108+ | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True
109+ | any (t `isLike`) ["n", "no", "off", "false"] = Bool False
110+#if MIN_VERSION_aeson(0, 7, 0)
111+ | Right (x, "") <- signed decimal t = Number $ fromIntegral (x :: Integer)
112+ | Right (x, "") <- double t = Number $ fromFloatDigits x
113+#else
114+ | Right (x, "") <- signed decimal t = Number $ I x
115+ | Right (x, "") <- double t = Number $ D x
116+#endif
117+ | otherwise = String t
118+ where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]
119+ where titleCased = toUpper (T.head ref) `T.cons` T.tail ref
120+
121+
122+parseO :: C.Sink Event Parse Value
123+parseO = do
124+ me <- CL.head
125+ case me of
126+ Just (EventScalar v tag style a) -> fmap (textToValue style tag) $ parseScalar v a style tag
127+ Just (EventSequenceStart a) -> parseS a id
128+ Just (EventMappingStart a) -> parseM a M.empty
129+ Just (EventAlias an) -> do
130+ m <- lift get
131+ case Map.lookup an m of
132+ Nothing -> liftIO $ throwIO $ UnknownAlias an
133+ Just v -> return v
134+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
135+
136+parseS :: Y.Anchor
137+ -> ([Value] -> [Value])
138+ -> C.Sink Event Parse Value
139+parseS a front = do
140+ me <- CL.peek
141+ case me of
142+ Just EventSequenceEnd -> do
143+ CL.drop 1
144+ let res = Array $ V.fromList $ front []
145+ case a of
146+ Nothing -> return res
147+ Just an -> do
148+ lift $ modify $ Map.insert an res
149+ return res
150+ _ -> do
151+ o <- parseO
152+ parseS a $ front . (:) o
153+
154+parseM :: Y.Anchor
155+ -> M.HashMap Text Value
156+ -> C.Sink Event Parse Value
157+parseM a front = do
158+ me <- CL.peek
159+ case me of
160+ Just EventMappingEnd -> do
161+ CL.drop 1
162+ let res = Object 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+ CL.drop 1
170+ s <- case me of
171+ Just (EventScalar v tag style a') -> parseScalar v a' style tag
172+ Just (EventAlias an) -> do
173+ m <- lift get
174+ case Map.lookup an m of
175+ Nothing -> liftIO $ throwIO $ UnknownAlias an
176+ Just (String t) -> return t
177+ Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
178+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
179+ o <- parseO
180+
181+ let al = M.insert s o front
182+ al' = if s == pack "<<"
183+ then case o of
184+ Object l -> M.union front l
185+ Array l -> M.union front $ foldl merge' M.empty $ V.toList l
186+ _ -> al
187+ else al
188+ parseM a al'
189+ where merge' al (Object om) = M.union al om
190+ merge' al _ = al
191+
192+decodeHelper :: FromJSON a
193+ => C.Source Parse Y.Event
194+ -> IO (Either ParseException (Either String a))
195+decodeHelper src = do
196+ x <- try $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse
197+ case x of
198+ Left e
199+ | Just pe <- fromException e -> return $ Left pe
200+ | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
201+ | otherwise -> throwIO e
202+ Right y -> return $ Right $ parseEither parseJSON y
yaml.cabal+2
@@ -58,6 +58,8 @@ library
58 Data.Yaml.Builder
58 Data.Yaml.Builder
59 Data.Yaml.Parser
59 Data.Yaml.Parser
60 Data.Yaml.Include
60 Data.Yaml.Include
61+ other-modules:
62+ Data.Yaml.Internal
61 ghc-options: -Wall
63 ghc-options: -Wall
62 c-sources: c/helper.c
64 c-sources: c/helper.c
63 include-dirs: c
65 include-dirs: c