yaml 0.9.0 → 0.10.0
raw patch · 6 files changed
+178/−80 lines, 6 filesdep +mtl
Dependencies added: mtl
Files
- ChangeLog.md +4/−0
- src/Data/Yaml.hs +16/−5
- src/Data/Yaml/Include.hs +18/−4
- src/Data/Yaml/Internal.hs +63/−67
- test/Data/Yaml/IncludeSpec.hs +66/−0
- yaml.cabal +11/−4
ChangeLog.md view
@@ -1,5 +1,9 @@ # ChangeLog for yaml +## 0.10.0++* Add `decodeFileWithWarnings` which returns warnings for duplicate fields+ ## 0.9.0 * Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)
src/Data/Yaml.hs view
@@ -32,6 +32,7 @@ -- * Decoding , decodeEither' , decodeFileEither+ , decodeFileWithWarnings , decodeThrow , decodeFileThrow -- ** More control over decoding@@ -163,14 +164,14 @@ => ByteString -> Maybe a decode bs = unsafePerformIO- $ either (const Nothing) id+ $ either (const Nothing) snd <$> decodeHelper_ (Y.decode bs) {-# DEPRECATED decode "Please use decodeEither or decodeThrow, which provide information on how the decode failed" #-} decodeFile :: FromJSON a => FilePath -> IO (Maybe a)-decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO (return . either (const Nothing) id)+decodeFile fp = (fmap snd <$> decodeHelper (Y.decodeFile fp)) >>= either throwIO (return . either (const Nothing) id) {-# DEPRECATED decodeFile "Please use decodeFileEither, which does not confused type-directed and runtime exceptions." #-} -- | A version of 'decodeFile' which should not throw runtime exceptions.@@ -180,12 +181,22 @@ :: FromJSON a => FilePath -> IO (Either ParseException a)-decodeFileEither = decodeHelper_ . Y.decodeFile+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings +-- | A version of `decodeFileEither` that returns warnings along with the parse+-- result.+--+-- @since 0.10.0+decodeFileWithWarnings+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException ([Warning], a))+decodeFileWithWarnings = decodeHelper_ . Y.decodeFile+ decodeEither :: FromJSON a => ByteString -> Either String a decodeEither bs = unsafePerformIO $ either (Left . prettyPrintParseException) id- <$> decodeHelper (Y.decode bs)+ <$> (fmap snd <$> decodeHelper (Y.decode bs)) {-# DEPRECATED decodeEither "Please use decodeEither' or decodeThrow, which provide more useful failures" #-} -- | More helpful version of 'decodeEither' which returns the 'YamlException'.@@ -194,7 +205,7 @@ decodeEither' :: FromJSON a => ByteString -> Either ParseException a decodeEither' = either Left (either (Left . AesonException) Right) . unsafePerformIO- . decodeHelper+ . fmap (fmap snd) . decodeHelper . Y.decode -- | A version of 'decodeEither'' lifted to MonadThrow
src/Data/Yaml/Include.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-}-module Data.Yaml.Include (decodeFile, decodeFileEither) where+module Data.Yaml.Include (+ decodeFile+, decodeFileEither+, decodeFileWithWarnings+) where #if !MIN_VERSION_directory(1, 2, 3) import Control.Exception (handleJust)@@ -20,7 +24,7 @@ import System.Directory import System.FilePath -import Data.Yaml.Internal (ParseException(..), decodeHelper_, decodeHelper)+import Data.Yaml.Internal (ParseException(..), Warning(..), decodeHelper_, decodeHelper) import Text.Libyaml hiding (decodeFile) import qualified Text.Libyaml as Y @@ -65,7 +69,7 @@ :: FromJSON a => FilePath -> IO (Maybe a)-decodeFile fp = decodeHelper (eventsFromFile fp) >>= either throwIO (return . either (const Nothing) id)+decodeFile fp = (fmap snd <$> decodeHelper (eventsFromFile fp)) >>= either throwIO (return . either (const Nothing) id) -- | Like `Data.Yaml.decodeFileEither` but with support for relative and -- absolute includes.@@ -77,4 +81,14 @@ :: FromJSON a => FilePath -> IO (Either ParseException a)-decodeFileEither = decodeHelper_ . eventsFromFile+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings++-- | A version of `decodeFileEither` that returns warnings along with the parse+-- result.+--+-- @since 0.10.0+decodeFileWithWarnings+ :: FromJSON a+ => FilePath+ -> IO (Either ParseException ([Warning], a))+decodeFileWithWarnings = decodeHelper_ . eventsFromFile
src/Data/Yaml/Internal.hs view
@@ -6,6 +6,7 @@ ( ParseException(..) , prettyPrintParseException+ , Warning(..) , parse , decodeHelper , decodeHelper_@@ -19,22 +20,25 @@ #endif import Control.Applicative ((<|>)) import Control.Exception-import Control.Monad (liftM, ap, unless)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad (when, unless) import Control.Monad.Trans.Resource (ResourceT, runResourceT)-import Control.Monad.Trans.State+import Control.Monad.RWS import Data.Aeson+import Data.Aeson.Internal (JSONPath, JSONPathElement(..)) import Data.Aeson.Types hiding (parse) import qualified Data.Attoparsec.Text as Atto import Data.Bits (shiftL, (.|.)) import Data.ByteString (ByteString) import Data.Char (toUpper, ord)+import Data.List import Data.Conduit ((.|), ConduitM, runConduit) import qualified Data.Conduit.List as CL import qualified Data.HashMap.Strict as M import qualified Data.HashSet as HashSet+import Data.Map (Map) import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set import Data.Scientific (Scientific) import Data.Text (Text, pack) import qualified Data.Text as T@@ -108,26 +112,20 @@ ] CyclicIncludes -> "Cyclic includes" -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 = PErrorT . return . Right- (<*>) = ap-instance Monad m => Monad (PErrorT m) where- return = pure- (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+defineAnchor :: Value -> String -> ConduitM e o Parse ()+defineAnchor value name = modify $ Map.insert name value -type Parse = StateT (Map.Map String Value) (ResourceT IO)+lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)+lookupAnchor name = gets (Map.lookup name) +data Warning = DuplicateKey JSONPath+ deriving (Eq, Show)++addWarning :: Warning -> ConduitM e o Parse ()+addWarning = tell . return++type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)+ requireEvent :: Event -> ConduitM Event o Parse () requireEvent e = do f <- CL.head@@ -158,11 +156,8 @@ -> ConduitM Event o 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+ mapM_ (defineAnchor (textToValue style tag res)) a+ return res textToValue :: Style -> Tag -> Text -> Value textToValue SingleQuoted _ t = String t@@ -195,100 +190,101 @@ me <- CL.head case me of Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag- Just (EventSequenceStart _ _ a) -> parseS a id- Just (EventMappingStart _ _ a) -> parseM a M.empty+ Just (EventSequenceStart _ _ a) -> parseS 0 a id+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty Just (EventAlias an) -> do- m <- lift get- case Map.lookup an m of+ m <- lookupAnchor an+ case m of Nothing -> liftIO $ throwIO $ UnknownAlias an Just v -> return v _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing -parseS :: Y.Anchor+parseS :: Int+ -> Y.Anchor -> ([Value] -> [Value]) -> ConduitM Event o Parse Value-parseS a front = do+parseS n 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+ mapM_ (defineAnchor res) a+ return res _ -> do- o <- parseO- parseS a $ front . (:) o+ o <- local (Index n :) parseO+ parseS (succ n) a $ front . (:) o -parseM :: Y.Anchor+parseM :: Set Text+ -> Y.Anchor -> M.HashMap Text Value -> ConduitM Event o Parse Value-parseM a front = do- me <- CL.peek+parseM mergedKeys a front = do+ me <- CL.head 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+ mapM_ (defineAnchor res) a+ 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+ m <- lookupAnchor an+ case 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 "<<"+ (mergedKeys', al') <- local (Key s :) $ do+ o <- parseO+ let al = do+ when (M.member s front && Set.notMember s mergedKeys) $ do+ path <- reverse <$> ask+ addWarning (DuplicateKey path)+ return (Set.delete s mergedKeys, M.insert s o front)+ 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+ Object l -> return (merge l)+ Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l _ -> al else al- parseM a al'- where merge' al (Object om) = M.union al om- merge' al _ = al+ parseM mergedKeys' a al'+ where mergeObjects al (Object om) = M.union al om+ mergeObjects al _ = al + merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)+ decodeHelper :: FromJSON a => ConduitM () Y.Event Parse ()- -> IO (Either ParseException (Either String a))+ -> IO (Either ParseException ([Warning], Either String a)) decodeHelper src = do -- 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 $ flip evalStateT Map.empty $ runConduit $ src .| parse+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] 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 -> return $ Right $ parseEither parseJSON y+ Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y) decodeHelper_ :: FromJSON a => ConduitM () Event Parse ()- -> IO (Either ParseException a)+ -> IO (Either ParseException ([Warning], a)) decodeHelper_ src = do- x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] 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 -> either+ Right (y, warnings) -> either (Left . AesonException) Right- (parseEither parseJSON y)+ ((,) warnings <$> 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
@@ -1,12 +1,18 @@+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} module Data.Yaml.IncludeSpec (main, spec) where import Test.Hspec import Data.List (isPrefixOf) import Data.Aeson+import Data.Aeson.Internal (JSONPathElement(..)) import Data.Yaml (ParseException(InvalidYaml)) import Data.Yaml.Include+import Data.Yaml.Internal import Text.Libyaml (YamlException(YamlException))+import Test.Mockery.Directory+import Text.RawString.QQ+import Data.Yaml.TH (yamlQQ) main :: IO () main = hspec spec@@ -51,6 +57,66 @@ it "returns Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>= (`shouldSatisfy` either isYamlFileNotFoundException (const False))++ describe "decodeFileWithWarnings" $ around_ inTempDirectory $ do+ it "warns on duplicate keys" $ do+ writeFile "foo.yaml" [r|+ foo: 23+ foo: bar+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo"]], [yamlQQ|+ foo: bar+ |])++ it "warns on nested duplicate keys" $ do+ writeFile "foo.yaml" [r|+ foo:+ - 42+ - bar: 23+ bar: baz+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo", Index 1, Key "bar"]], [yamlQQ|+ foo:+ - 42+ - bar: baz+ |])++ context "when overriding a merged key" $ do+ it "does not warn" $ do+ writeFile "foo.yaml" [r|+ foo-1: &my-ref+ bar: 23+ foo-2:+ <<: *my-ref+ bar: 42+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([], [yamlQQ|+ foo-1:+ bar: 23+ foo-2:+ bar: 42+ |])++ context "when overriding twice" $ do+ it "warns" $ do+ writeFile "foo.yaml" [r|+ foo-1: &my-ref+ bar: 23+ foo-2:+ <<: *my-ref+ bar: 42+ bar: 65+ |]+ Right result <- decodeFileWithWarnings "foo.yaml"+ result `shouldBe` ([DuplicateKey [Key "foo-2", Key "bar"]], [yamlQQ|+ foo-1:+ bar: 23+ foo-2:+ bar: 65+ |]) isYamlFileNotFoundException :: ParseException -> Bool isYamlFileNotFoundException (InvalidYaml (Just (YamlException msg)))
yaml.cabal view
@@ -1,11 +1,13 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+cabal-version: >= 1.10++-- This file has been generated from package.yaml by hpack version 0.29.6. -- -- see: https://github.com/sol/hpack ----- hash: 2de1bae80ae10ae93990897198f5e06bc3ff88eefd9e0087e6384bca7a887515+-- hash: a82d0ad23c31e4d461a49236c789475df6276479abe75c53c04f33be563b808f name: yaml-version: 0.9.0+version: 0.10.0 synopsis: Support for parsing and rendering YAML documents. description: README and API documentation are available at <https://www.stackage.org/package/yaml> category: Data@@ -17,7 +19,6 @@ license: BSD3 license-file: LICENSE build-type: Simple-cabal-version: >= 1.10 extra-source-files: c/helper.h ChangeLog.md@@ -91,6 +92,7 @@ , containers , directory , filepath+ , mtl , resourcet >=0.3 && <1.3 , scientific , semigroups@@ -135,6 +137,7 @@ , containers , directory , filepath+ , mtl , resourcet >=0.3 && <1.3 , scientific , semigroups@@ -166,6 +169,7 @@ , containers , directory , filepath+ , mtl , resourcet >=0.3 && <1.3 , scientific , semigroups@@ -194,6 +198,7 @@ , containers , directory , filepath+ , mtl , resourcet >=0.3 && <1.3 , scientific , semigroups@@ -232,6 +237,8 @@ , filepath , hspec >=1.3 , mockery+ , mtl+ , raw-strings-qq , resourcet >=0.3 && <1.3 , scientific , semigroups