yaml 0.8.10 → 0.8.10.1
raw patch · 6 files changed
+250/−210 lines, 6 filesdep +enclosed-exceptionsdep +hspec-expectationsdep ~conduit
Dependencies added: enclosed-exceptions, hspec-expectations
Dependency ranges changed: conduit
Files
- Data/Yaml.hs +9/−204
- Data/Yaml/Include.hs +2/−3
- Data/Yaml/Internal.hs +219/−0
- test/Data/Yaml/IncludeSpec.hs +7/−0
- test/Data/YamlSpec.hs +7/−1
- yaml.cabal +6/−2
Data/Yaml.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}@@ -66,38 +62,28 @@ import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser) import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile) import Data.ByteString (ByteString)-import qualified Data.Map as Map import System.IO.Unsafe (unsafePerformIO)-import Control.Exception (try, throwIO, fromException, Exception, SomeException, AsyncException)-import Control.Monad.Trans.State+import Control.Exception import qualified Data.Conduit as C import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad (liftM, ap)-import Control.Applicative (Applicative(..))-import Data.Char (toUpper) import qualified Data.Vector as V-import Data.Text (Text, pack)+import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)+import Data.Text.Encoding (encodeUtf8) import qualified Data.HashMap.Strict as M-import Data.Typeable import qualified Data.HashSet as HashSet-import Data.Text.Read #if MIN_VERSION_aeson(0, 7, 0)-import Data.Scientific (fromFloatDigits) import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (toLazyText) import Data.Aeson.Encode (encodeToTextBuilder) #else-import Data.Attoparsec.Number import qualified Data.ByteString.Char8 as S8 #endif-import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Control.Monad.Trans.Resource (runResourceT) +import Data.Yaml.Internal+ encode :: ToJSON a => a -> ByteString encode obj = unsafePerformIO $ runResourceT $ CL.sourceList (objToEvents $ toJSON obj)@@ -172,164 +158,12 @@ || c == '.' || c == '-' --- Parsing--data ParseException = NonScalarKey- | UnknownAlias { _anchorName :: Y.AnchorName }- | UnexpectedEvent { _received :: Maybe Event- , _expected :: Maybe Event- }- | InvalidYaml (Maybe YamlException)- | AesonException String- | OtherParseException SomeException- | NonStringKeyAlias Y.AnchorName Value- | CyclicIncludes- deriving (Show, Typeable)-instance Exception ParseException--newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }-instance Monad m => Functor (PErrorT m) where- fmap = liftM-instance Monad m => Applicative (PErrorT m) where- pure = return- (<*>) = ap-instance Monad m => Monad (PErrorT m) where- return = PErrorT . return . Right- (PErrorT m) >>= f = PErrorT $ do- e <- m- case e of- Left e' -> return $ Left e'- Right a -> runPErrorT $ f a-instance MonadTrans PErrorT where- lift = PErrorT . liftM Right-instance MonadIO m => MonadIO (PErrorT m) where- liftIO = lift . liftIO--type Parse = StateT (Map.Map String Value) (ResourceT IO)--requireEvent :: Event -> C.Sink Event Parse ()-requireEvent e = do- f <- CL.head- if f == Just e- then return ()- else liftIO $ throwIO $ UnexpectedEvent f $ Just e--parse :: C.Sink Event Parse Value-parse = do- requireEvent EventStreamStart- requireEvent EventDocumentStart- res <- parseO- requireEvent EventDocumentEnd- requireEvent EventStreamEnd- return res--parseScalar :: ByteString -> Anchor -> Style -> Tag- -> C.Sink Event Parse Text-parseScalar v a style tag = do- let res = decodeUtf8With lenientDecode v- case a of- Nothing -> return res- Just an -> do- lift $ modify (Map.insert an $ textToValue style tag res)- return res--textToValue :: Style -> Tag -> Text -> Value-textToValue SingleQuoted _ t = String t-textToValue DoubleQuoted _ t = String t-textToValue _ StrTag t = String t-textToValue Folded _ t = String t-textToValue _ _ t- | t `elem` ["null", "Null", "NULL", "~", ""] = Null- | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True- | any (t `isLike`) ["n", "no", "off", "false"] = Bool False-#if MIN_VERSION_aeson(0, 7, 0)- | Right (x, "") <- signed decimal t = Number $ fromIntegral (x :: Integer)- | Right (x, "") <- double t = Number $ fromFloatDigits x-#else- | Right (x, "") <- signed decimal t = Number $ I x- | Right (x, "") <- double t = Number $ D x-#endif- | otherwise = String t- where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]- where titleCased = toUpper (T.head ref) `T.cons` T.tail ref---parseO :: C.Sink Event Parse Value-parseO = do- me <- CL.head- case me of- Just (EventScalar v tag style a) -> fmap (textToValue style tag) $ parseScalar v a style tag- Just (EventSequenceStart a) -> parseS a id- Just (EventMappingStart a) -> parseM a M.empty- Just (EventAlias an) -> do- m <- lift get- case Map.lookup an m of- Nothing -> liftIO $ throwIO $ UnknownAlias an- Just v -> return v- _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing--parseS :: Y.Anchor- -> ([Value] -> [Value])- -> C.Sink Event Parse Value-parseS a front = do- me <- CL.peek- case me of- Just EventSequenceEnd -> do- CL.drop 1- let res = Array $ V.fromList $ front []- case a of- Nothing -> return res- Just an -> do- lift $ modify $ Map.insert an res- return res- _ -> do- o <- parseO- parseS a $ front . (:) o--parseM :: Y.Anchor- -> M.HashMap Text Value- -> C.Sink Event Parse Value-parseM a front = do- me <- CL.peek- case me of- Just EventMappingEnd -> do- CL.drop 1- let res = Object front- case a of- Nothing -> return res- Just an -> do- lift $ modify $ Map.insert an res- return res- _ -> do- CL.drop 1- s <- case me of- Just (EventScalar v tag style a') -> parseScalar v a' style tag- Just (EventAlias an) -> do- m <- lift get- case Map.lookup an m of- Nothing -> liftIO $ throwIO $ UnknownAlias an- Just (String t) -> return t- Just v -> liftIO $ throwIO $ NonStringKeyAlias an v- _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing- o <- parseO-- let al = M.insert s o front- al' = if s == pack "<<"- then case o of- Object l -> M.union front l- Array l -> M.union front $ foldl merge' M.empty $ V.toList l- _ -> al- else al- parseM a al'- where merge' al (Object om) = M.union al om- merge' al _ = al- decode :: FromJSON a => ByteString -> Maybe a decode bs = unsafePerformIO- $ fmap (either (const Nothing) (either (const Nothing) Just))- $ decodeHelper (Y.decode bs)+ $ fmap (either (const Nothing) id)+ $ decodeHelper_ (Y.decode bs) decodeFile :: FromJSON a => FilePath@@ -343,24 +177,7 @@ :: FromJSON a => FilePath -> IO (Either ParseException a)-decodeFileEither fp = do- x <- try $ runResourceT $ flip evalStateT Map.empty $ Y.decodeFile fp C.$$ parse- case x of- Left e- | Just pe <- fromException e -> return $ Left pe- | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)- | shouldBeCaught e -> return $ Left $ OtherParseException e- | otherwise -> throwIO e- Right y ->- return $ case parseEither parseJSON y of- Left s -> Left $ AesonException s- Right v -> Right v- where- -- FIXME this function needs more thought- shouldBeCaught e- | Just (_ :: AsyncException) <- fromException e = False- -- Would be nice... | Just (_ :: Timeout) <- fromException e = False- | otherwise = True+decodeFileEither = decodeHelper_ . Y.decodeFile decodeEither :: FromJSON a => ByteString -> Either String a decodeEither bs = unsafePerformIO@@ -375,18 +192,6 @@ . unsafePerformIO . decodeHelper . Y.decode--decodeHelper :: FromJSON a- => C.Source Parse Y.Event- -> IO (Either ParseException (Either String a))-decodeHelper src = do- x <- try $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse- case x of- Left e- | Just pe <- fromException e -> return $ Left pe- | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)- | otherwise -> throwIO e- Right y -> return $ Right $ parseEither parseJSON y array :: [Value] -> Value array = Array . V.fromList
Data/Yaml/Include.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes #-} module Data.Yaml.Include (decodeFile, decodeFileEither) where -import Control.Applicative import Control.Monad (when) import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO)@@ -13,7 +12,7 @@ import Data.Aeson (FromJSON) import Data.Conduit import qualified Data.Conduit.List as CL-import Data.Yaml (ParseException(..), decodeHelper)+import Data.Yaml.Internal (ParseException(..), decodeHelper_, decodeHelper) import Text.Libyaml hiding (decodeFile) import qualified Text.Libyaml as Y @@ -59,4 +58,4 @@ :: FromJSON a => FilePath -> IO (Either ParseException a)-decodeFileEither fp = either Left (either (Left . AesonException) Right) <$> decodeHelper (eventsFromFile fp)+decodeFileEither = decodeHelper_ . eventsFromFile
+ Data/Yaml/Internal.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.Yaml.Internal+ (+ ParseException(..)+ , parse+ , decodeHelper+ , decodeHelper_+ ) where++import qualified Text.Libyaml as Y+import Data.Aeson+import Data.Aeson.Types hiding (parse)+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)+import Data.ByteString (ByteString)+import qualified Data.Map as Map+import Control.Exception+import Control.Exception.Enclosed+import Control.Monad.Trans.State+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (liftM, ap)+import Control.Applicative (Applicative(..))+import Data.Char (toUpper)+import qualified Data.Vector as V+import Data.Text (Text, pack)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.HashMap.Strict as M+import Data.Typeable+import Data.Text.Read+#if MIN_VERSION_aeson(0, 7, 0)+import Data.Scientific (fromFloatDigits)+#else+import Data.Attoparsec.Number+#endif+import Control.Monad.Trans.Resource (ResourceT, runResourceT)++data ParseException = NonScalarKey+ | UnknownAlias { _anchorName :: Y.AnchorName }+ | UnexpectedEvent { _received :: Maybe Event+ , _expected :: Maybe Event+ }+ | InvalidYaml (Maybe YamlException)+ | AesonException String+ | OtherParseException SomeException+ | NonStringKeyAlias Y.AnchorName Value+ | CyclicIncludes+ deriving (Show, Typeable)+instance Exception ParseException++newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }+instance Monad m => Functor (PErrorT m) where+ fmap = liftM+instance Monad m => Applicative (PErrorT m) where+ pure = return+ (<*>) = ap+instance Monad m => Monad (PErrorT m) where+ return = PErrorT . return . Right+ (PErrorT m) >>= f = PErrorT $ do+ e <- m+ case e of+ Left e' -> return $ Left e'+ Right a -> runPErrorT $ f a+instance MonadTrans PErrorT where+ lift = PErrorT . liftM Right+instance MonadIO m => MonadIO (PErrorT m) where+ liftIO = lift . liftIO++type Parse = StateT (Map.Map String Value) (ResourceT IO)++requireEvent :: Event -> C.Sink Event Parse ()+requireEvent e = do+ f <- CL.head+ if f == Just e+ then return ()+ else liftIO $ throwIO $ UnexpectedEvent f $ Just e++parse :: C.Sink Event Parse Value+parse = do+ requireEvent EventStreamStart+ requireEvent EventDocumentStart+ res <- parseO+ requireEvent EventDocumentEnd+ requireEvent EventStreamEnd+ return res++parseScalar :: ByteString -> Anchor -> Style -> Tag+ -> C.Sink Event Parse Text+parseScalar v a style tag = do+ let res = decodeUtf8With lenientDecode v+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify (Map.insert an $ textToValue style tag res)+ return res++textToValue :: Style -> Tag -> Text -> Value+textToValue SingleQuoted _ t = String t+textToValue DoubleQuoted _ t = String t+textToValue _ StrTag t = String t+textToValue Folded _ t = String t+textToValue _ _ t+ | t `elem` ["null", "Null", "NULL", "~", ""] = Null+ | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True+ | any (t `isLike`) ["n", "no", "off", "false"] = Bool False+#if MIN_VERSION_aeson(0, 7, 0)+ | Right (x, "") <- signed decimal t = Number $ fromIntegral (x :: Integer)+ | Right (x, "") <- double t = Number $ fromFloatDigits x+#else+ | Right (x, "") <- signed decimal t = Number $ I x+ | Right (x, "") <- double t = Number $ D x+#endif+ | otherwise = String t+ where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]+ where titleCased = toUpper (T.head ref) `T.cons` T.tail ref+++parseO :: C.Sink Event Parse Value+parseO = do+ me <- CL.head+ case me of+ Just (EventScalar v tag style a) -> fmap (textToValue style tag) $ parseScalar v a style tag+ Just (EventSequenceStart a) -> parseS a id+ Just (EventMappingStart a) -> parseM a M.empty+ Just (EventAlias an) -> do+ m <- lift get+ case Map.lookup an m of+ Nothing -> liftIO $ throwIO $ UnknownAlias an+ Just v -> return v+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing++parseS :: Y.Anchor+ -> ([Value] -> [Value])+ -> C.Sink Event Parse Value+parseS a front = do+ me <- CL.peek+ case me of+ Just EventSequenceEnd -> do+ CL.drop 1+ let res = Array $ V.fromList $ front []+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify $ Map.insert an res+ return res+ _ -> do+ o <- parseO+ parseS a $ front . (:) o++parseM :: Y.Anchor+ -> M.HashMap Text Value+ -> C.Sink Event Parse Value+parseM a front = do+ me <- CL.peek+ case me of+ Just EventMappingEnd -> do+ CL.drop 1+ let res = Object front+ case a of+ Nothing -> return res+ Just an -> do+ lift $ modify $ Map.insert an res+ return res+ _ -> do+ CL.drop 1+ s <- case me of+ Just (EventScalar v tag style a') -> parseScalar v a' style tag+ Just (EventAlias an) -> do+ m <- lift get+ case Map.lookup an m of+ Nothing -> liftIO $ throwIO $ UnknownAlias an+ Just (String t) -> return t+ Just v -> liftIO $ throwIO $ NonStringKeyAlias an v+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing+ o <- parseO++ let al = M.insert s o front+ al' = if s == pack "<<"+ then case o of+ Object l -> M.union front l+ Array l -> M.union front $ foldl merge' M.empty $ V.toList l+ _ -> al+ else al+ parseM a al'+ where merge' al (Object om) = M.union al om+ merge' al _ = al++decodeHelper :: FromJSON a+ => C.Source Parse Y.Event+ -> IO (Either ParseException (Either String a))+decodeHelper src = do+ x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse+ case x of+ Left e+ | Just pe <- fromException e -> return $ Left pe+ | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)+ | otherwise -> throwIO e+ Right y -> return $ Right $ parseEither parseJSON y++decodeHelper_ :: FromJSON a+ => C.Source Parse Event+ -> IO (Either ParseException a)+decodeHelper_ src = do+ x <- tryAny $ runResourceT $ flip evalStateT Map.empty $ src C.$$ parse+ return $ case x of+ Left e+ | Just pe <- fromException e -> Left pe+ | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)+ | otherwise -> Left $ OtherParseException e+ Right y -> either+ (Left . AesonException)+ Right+ (parseEither parseJSON y)
test/Data/Yaml/IncludeSpec.hs view
@@ -2,8 +2,10 @@ module Data.Yaml.IncludeSpec (main, spec) where import Test.Hspec+import Test.Hspec.Expectations.Contrib import Data.Aeson import Data.Aeson.QQ+import Data.Yaml (ParseException) import Data.Yaml.Include @@ -35,3 +37,8 @@ it "aborts on cyclic includes" $ do (decodeFile "test/resources/loop/foo.yaml" :: IO (Maybe Value)) `shouldThrow` anyException++ describe "decodeFileEither" $ do+ context "when file does not exist" $ do+ it "returns Left" $ do+ (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>= (`shouldSatisfy` isLeft)
test/Data/YamlSpec.hs view
@@ -19,6 +19,7 @@ import Control.Monad import Control.Exception (try, SomeException) import Test.Hspec+import Test.Hspec.Expectations.Contrib import qualified Data.Yaml as D import Data.Yaml (object, array, (.=))@@ -114,7 +115,7 @@ in D.decode (D.encode value') `shouldBe` Just value' mapM_ tester specialStrings - describe "yamlFileJSONparse" $+ describe "decodeFileEither" $ do it "loads YAML through JSON into Haskell data" $ do tj <- either (error . show) id `fmap` D.decodeFileEither "test/json.yaml" tj `shouldBe` TestJSON@@ -124,6 +125,11 @@ , hash = HM.fromList [("key1", "value1"), ("key2", "value2")] , extrastring = "1234-foo" }++ context "when file does not exist" $ do+ it "returns Left" $ do+ (D.decodeFileEither "./does_not_exist.yaml" :: IO (Either D.ParseException D.Value)) >>= (`shouldSatisfy` isLeft)+ describe "round-tripping of special scalars" $ do let special = words "y Y On ON false 12345 12345.0 12345a 12e3"
yaml.cabal view
@@ -1,5 +1,5 @@ name: yaml-version: 0.8.10+version: 0.8.10.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov @@ -41,7 +41,7 @@ build-depends: base >= 4 && < 5 , transformers >= 0.1 , bytestring >= 0.9.1.4- , conduit >= 1.0.11 && < 1.3+ , conduit >= 1.1.0 && < 1.3 , resourcet >= 0.3 && < 1.2 , aeson >= 0.5 , containers@@ -52,12 +52,15 @@ , scientific , filepath , directory+ , enclosed-exceptions exposed-modules: Text.Libyaml Data.Yaml Data.Yaml.Aeson Data.Yaml.Builder Data.Yaml.Parser Data.Yaml.Include+ other-modules:+ Data.Yaml.Internal ghc-options: -Wall c-sources: c/helper.c include-dirs: c@@ -111,6 +114,7 @@ Data.Yaml.IncludeSpec cpp-options: -DTEST build-depends: hspec >= 1.3+ , hspec-expectations , HUnit , directory , base >= 4 && < 5