@@ -1,8 +1,4 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
31{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveDataTypeable #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
62{-# LANGUAGE PatternGuards #-}
73{-# LANGUAGE ScopedTypeVariables #-}
84{-# LANGUAGE OverloadedStrings #-}
@@ -66,37 +62,27 @@ import Data.Aeson
6662import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser)
6763import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
6864import Data.ByteString (ByteString)
69−import qualified Data.Map as Map
7065import System.IO.Unsafe (unsafePerformIO)
71−import Control.Exception (try, throwIO, fromException, Exception, SomeException, AsyncException)
72−import Control.Monad.Trans.State
66+import Control.Exception
7367import qualified Data.Conduit as C
7468import 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)
8069import qualified Data.Vector as V
81−import Data.Text (Text, pack)
70+import Data.Text (Text)
8271import qualified Data.Text as T
83−import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
84−import Data.Text.Encoding.Error (lenientDecode)
72+import Data.Text.Encoding (encodeUtf8)
8573import qualified Data.HashMap.Strict as M
86−import Data.Typeable
8774import qualified Data.HashSet as HashSet
88−import Data.Text.Read
8975#if MIN_VERSION_aeson(0, 7, 0)
90−import Data.Scientific (fromFloatDigits)
9176import qualified Data.Text.Encoding as TE
9277import qualified Data.Text.Lazy as TL
9378import Data.Text.Lazy.Builder (toLazyText)
9479import Data.Aeson.Encode (encodeToTextBuilder)
9580#else
96−import Data.Attoparsec.Number
9781import qualified Data.ByteString.Char8 as S8
9882#endif
99−import Control.Monad.Trans.Resource (ResourceT, runResourceT)
83+import Control.Monad.Trans.Resource (runResourceT)
84+
85+import Data.Yaml.Internal
10086
10187encode :: ToJSON a => a -> ByteString
10288encode obj = unsafePerformIO $
@@ -172,164 +158,12 @@ isNumeric =
172158 || c == '.'
173159 || c == '-'
174160
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−
327161decode :: FromJSON a
328162 => ByteString
329163 -> Maybe a
330164decode bs = unsafePerformIO
331− $ fmap (either (const Nothing) (either (const Nothing) Just))
332− $ decodeHelper (Y.decode bs)
165+ $ fmap (either (const Nothing) id)
166+ $ decodeHelper_ (Y.decode bs)
333167
334168decodeFile :: FromJSON a
335169 => FilePath
@@ -343,24 +177,7 @@ decodeFileEither
343177 :: FromJSON a
344178 => FilePath
345179 -> IO (Either ParseException a)
346−decodeFileEither fp = do
347− x <- try $ runResourceT $ flip evalStateT Map.empty $ Y.decodeFile fp C.$$ parse
348− case x of
349− Left e
350− | Just pe <- fromException e -> return $ Left pe
351− | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
352− | shouldBeCaught e -> return $ Left $ OtherParseException e
353− | otherwise -> throwIO e
354− Right y ->
355− return $ case parseEither parseJSON y of
356− Left s -> Left $ AesonException s
357− Right v -> Right v
358− where
359− -- FIXME this function needs more thought
360− shouldBeCaught e
361− | Just (_ :: AsyncException) <- fromException e = False
362− -- Would be nice... | Just (_ :: Timeout) <- fromException e = False
363− | otherwise = True
180+decodeFileEither = decodeHelper_ . Y.decodeFile
364181
365182decodeEither :: FromJSON a => ByteString -> Either String a
366183decodeEither bs = unsafePerformIO
@@ -376,18 +193,6 @@ decodeEither' = either Left (either (Left . AesonException) Right)
376193 . decodeHelper
377194 . Y.decode
378195
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−
391196array :: [Value] -> Value
392197array = Array . V.fromList
393198