yaml 0.10.0 → 0.10.1
raw patch · 4 files changed
+74/−36 lines, 4 files
Files
- ChangeLog.md +5/−0
- src/Data/Yaml/Internal.hs +41/−28
- test/Data/Yaml/IncludeSpec.hs +10/−0
- yaml.cabal +18/−8
ChangeLog.md view
@@ -1,5 +1,10 @@ # ChangeLog for yaml +## 0.10.1++* Avoid incurring a `semigroups` dependency on recent GHCs.+* Fix a space leak that was introduced with `0.10.0` [#147](https://github.com/snoyberg/yaml/issues/147)+ ## 0.10.0 * Add `decodeFileWithWarnings` which returns warnings for duplicate fields
src/Data/Yaml/Internal.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-} module Data.Yaml.Internal ( ParseException(..)@@ -22,7 +23,8 @@ import Control.Exception import Control.Monad (when, unless) import Control.Monad.Trans.Resource (ResourceT, runResourceT)-import Control.Monad.RWS+import Control.Monad.State.Strict+import Control.Monad.Reader import Data.Aeson import Data.Aeson.Internal (JSONPath, JSONPathElement(..)) import Data.Aeson.Types hiding (parse)@@ -112,34 +114,45 @@ ] CyclicIncludes -> "Cyclic includes" -defineAnchor :: Value -> String -> ConduitM e o Parse ()-defineAnchor value name = modify $ Map.insert name value+defineAnchor :: Value -> String -> ReaderT JSONPath (ConduitM e o Parse) ()+defineAnchor value name = modify (modifyAnchors $ Map.insert name value)+ where+ modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState+ modifyAnchors f st = st {parseStateAnchors = f (parseStateAnchors st)} -lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)-lookupAnchor name = gets (Map.lookup name)+lookupAnchor :: String -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)+lookupAnchor name = gets (Map.lookup name . parseStateAnchors) data Warning = DuplicateKey JSONPath deriving (Eq, Show) -addWarning :: Warning -> ConduitM e o Parse ()-addWarning = tell . return+addWarning :: Warning -> ReaderT JSONPath (ConduitM e o Parse) ()+addWarning w = modify (modifyWarnings (w :))+ where+ modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState+ modifyWarnings f st = st {parseStateWarnings = f (parseStateWarnings st)} -type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)+data ParseState = ParseState {+ parseStateAnchors :: Map String Value+, parseStateWarnings :: [Warning]+} -requireEvent :: Event -> ConduitM Event o Parse ()+type Parse = StateT ParseState (ResourceT IO)++requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) () requireEvent e = do- f <- CL.head+ f <- lift CL.head unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e -parse :: ConduitM Event o Parse Value+parse :: ReaderT JSONPath (ConduitM Event o Parse) Value parse = do- streamStart <- CL.head+ streamStart <- lift CL.head case streamStart of Nothing -> -- empty string input return Null Just EventStreamStart -> do- documentStart <- CL.head+ documentStart <- lift CL.head case documentStart of Just EventStreamEnd -> -- empty file input, comment only string/file input@@ -153,7 +166,7 @@ _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing parseScalar :: ByteString -> Anchor -> Style -> Tag- -> ConduitM Event o Parse Text+ -> ReaderT JSONPath (ConduitM Event o Parse) Text parseScalar v a style tag = do let res = decodeUtf8With lenientDecode v mapM_ (defineAnchor (textToValue style tag res)) a@@ -185,9 +198,9 @@ isOctalDigit c = (c >= '0' && c <= '7') step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48) -parseO :: ConduitM Event o Parse Value+parseO :: ReaderT JSONPath (ConduitM Event o Parse) Value parseO = do- me <- CL.head+ me <- lift CL.head case me of Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag Just (EventSequenceStart _ _ a) -> parseS 0 a id@@ -202,12 +215,12 @@ parseS :: Int -> Y.Anchor -> ([Value] -> [Value])- -> ConduitM Event o Parse Value-parseS n a front = do- me <- CL.peek+ -> ReaderT JSONPath (ConduitM Event o Parse) Value+parseS !n a front = do+ me <- lift CL.peek case me of Just EventSequenceEnd -> do- CL.drop 1+ lift $ CL.drop 1 let res = Array $ V.fromList $ front [] mapM_ (defineAnchor res) a return res@@ -218,9 +231,9 @@ parseM :: Set Text -> Y.Anchor -> M.HashMap Text Value- -> ConduitM Event o Parse Value+ -> ReaderT JSONPath (ConduitM Event o Parse) Value parseM mergedKeys a front = do- me <- CL.head+ me <- lift CL.head case me of Just EventMappingEnd -> do let res = Object front@@ -247,7 +260,7 @@ if s == pack "<<" then case o of Object l -> return (merge l)- Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l+ Array l -> return $ merge $ foldl' mergeObjects M.empty $ V.toList l _ -> al else al parseM mergedKeys' a al'@@ -263,28 +276,28 @@ -- This used to be tryAny, but the fact is that catching async -- exceptions is fine here. We'll rethrow them immediately in the -- otherwise clause.- x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty []) 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, warnings) -> return $ Right (warnings, parseEither parseJSON y)+ Right (y, st) -> return $ Right (parseStateWarnings st, parseEither parseJSON y) decodeHelper_ :: FromJSON a => ConduitM () Event Parse () -> IO (Either ParseException ([Warning], a)) decodeHelper_ src = do- x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty []) 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, warnings) -> either+ Right (y, st) -> either (Left . AesonException) Right- ((,) warnings <$> parseEither parseJSON y)+ ((,) (parseStateWarnings st) <$> parseEither parseJSON y) -- | Strings which must be escaped so as not to be treated as non-string scalars. specialStrings :: HashSet.HashSet Text
test/Data/Yaml/IncludeSpec.hs view
@@ -4,6 +4,7 @@ import Test.Hspec import Data.List (isPrefixOf)+import qualified Data.ByteString.Lazy as LB import Data.Aeson import Data.Aeson.Internal (JSONPathElement(..)) import Data.Yaml (ParseException(InvalidYaml))@@ -51,6 +52,15 @@ context "when file does not exist" $ do it "throws Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do (decodeFile "./does_not_exist.yaml" :: IO (Maybe Value)) `shouldThrow` isYamlFileNotFoundException++ context "with a 1K stack size limit" $ around_ inTempDirectory $ do+ context "with a large list" $ do+ it "succeeds" $ do+ let+ xs :: [Value]+ xs = replicate 5000 (Number 23)+ LB.writeFile "foo.yaml" (encode xs)+ decodeFile "foo.yaml" `shouldReturn` Just xs describe "decodeFileEither" $ do context "when file does not exist" $ do
yaml.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: a82d0ad23c31e4d461a49236c789475df6276479abe75c53c04f33be563b808f+-- hash: 514c53ba5a36230ee3cda22bed82857fb3fe0ae4227b17ad757b65a87473b77a name: yaml-version: 0.10.0+version: 0.10.1 synopsis: Support for parsing and rendering YAML documents. description: README and API documentation are available at <https://www.stackage.org/package/yaml> category: Data@@ -95,12 +95,14 @@ , mtl , resourcet >=0.3 && <1.3 , scientific- , semigroups , template-haskell , text , transformers >=0.1 , unordered-containers , vector+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups if flag(no-unicode) cpp-options: -D__NO_UNICODE__ if !(flag(system-libyaml))@@ -140,12 +142,14 @@ , mtl , resourcet >=0.3 && <1.3 , scientific- , semigroups , template-haskell , text , transformers >=0.1 , unordered-containers , vector+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups if flag(no-examples) buildable: False else@@ -172,13 +176,15 @@ , mtl , resourcet >=0.3 && <1.3 , scientific- , semigroups , template-haskell , text , transformers >=0.1 , unordered-containers , vector , yaml+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups if flag(no-exe) buildable: False default-language: Haskell2010@@ -201,13 +207,15 @@ , mtl , resourcet >=0.3 && <1.3 , scientific- , semigroups , template-haskell , text , transformers >=0.1 , unordered-containers , vector , yaml+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups if flag(no-exe) buildable: False default-language: Haskell2010@@ -222,7 +230,7 @@ Paths_yaml hs-source-dirs: test- ghc-options: -Wall+ ghc-options: -Wall "-with-rtsopts=-K1K" cpp-options: -DTEST build-depends: HUnit@@ -241,7 +249,6 @@ , raw-strings-qq , resourcet >=0.3 && <1.3 , scientific- , semigroups , template-haskell , temporary , text@@ -249,4 +256,7 @@ , unordered-containers , vector , yaml+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups default-language: Haskell2010