b145da4 · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Merge pull request #146 from sol/dev

b145da4Michael Snoyman8 years ago

ChangeLog.md+4

compare with master

unifiedsplit

@@ -1,5 +1,9 @@

1# ChangeLog for yaml

3+## 0.10.0

5+* Add `decodeFileWithWarnings` which returns warnings for duplicate fields

3## 0.9.0

7## 0.9.0

5* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)

9* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)

package.yaml+3−1

@@ -1,5 +1,5 @@

1name: yaml

2−version: 0.9.0

2+version: 0.10.0

3synopsis: Support for parsing and rendering YAML documents.

4description: README and API documentation are available at <https://www.stackage.org/package/yaml>

5category: Data

@@ -49,6 +49,7 @@ dependencies:

49- base >=4.9.1 && <5 # GHC 8.0.2 and later

50- bytestring >=0.9.1.4

51- transformers >=0.1

52+- mtl

52- conduit >=1.2.8 && <1.4

53- conduit >=1.2.8 && <1.4

53- resourcet >=0.3 && <1.3

54- resourcet >=0.3 && <1.3

54- aeson >=0.11

55- aeson >=0.11

@@ -133,3 +134,4 @@ tests:

133 - mockery

134 - mockery

134 - base-compat

135 - base-compat

135 - temporary

136 - temporary

137+ - raw-strings-qq

src/Data/Yaml.hs+16−5

@@ -32,6 +32,7 @@ module Data.Yaml

32 -- * Decoding

33 , decodeEither'

34 , decodeFileEither

35+ , decodeFileWithWarnings

35 , decodeThrow

36 , decodeThrow

36 , decodeFileThrow

37 , decodeFileThrow

37 -- ** More control over decoding

38 -- ** More control over decoding

@@ -163,14 +164,14 @@ decode :: FromJSON a

163 => ByteString

164 => ByteString

164 -> Maybe a

165 -> Maybe a

165decode bs = unsafePerformIO

166decode bs = unsafePerformIO

166− $ either (const Nothing) id

167+ $ either (const Nothing) snd

167 <$> decodeHelper_ (Y.decode bs)

168 <$> decodeHelper_ (Y.decode bs)

168{-# DEPRECATED decode "Please use decodeEither or decodeThrow, which provide information on how the decode failed" #-}

169{-# DEPRECATED decode "Please use decodeEither or decodeThrow, which provide information on how the decode failed" #-}

169

170

170decodeFile :: FromJSON a

171decodeFile :: FromJSON a

171 => FilePath

172 => FilePath

172 -> IO (Maybe a)

173 -> IO (Maybe a)

173−decodeFile fp = decodeHelper (Y.decodeFile fp) >>= either throwIO (return . either (const Nothing) id)

174+decodeFile fp = (fmap snd <$> decodeHelper (Y.decodeFile fp)) >>= either throwIO (return . either (const Nothing) id)

174{-# DEPRECATED decodeFile "Please use decodeFileEither, which does not confused type-directed and runtime exceptions." #-}

175{-# DEPRECATED decodeFile "Please use decodeFileEither, which does not confused type-directed and runtime exceptions." #-}

175

176

176-- | A version of 'decodeFile' which should not throw runtime exceptions.

177-- | A version of 'decodeFile' which should not throw runtime exceptions.

@@ -180,12 +181,22 @@ decodeFileEither

180 :: FromJSON a

181 :: FromJSON a

181 => FilePath

182 => FilePath

182 -> IO (Either ParseException a)

183 -> IO (Either ParseException a)

184+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings

185+

186+-- | A version of `decodeFileEither` that returns warnings along with the parse

187+-- result.

188+--

189+-- @since 0.10.0

190+decodeFileWithWarnings

191+ :: FromJSON a

192+ => FilePath

193+ -> IO (Either ParseException ([Warning], a))

183−decodeFileEither = decodeHelper_ . Y.decodeFile

194+decodeFileWithWarnings = decodeHelper_ . Y.decodeFile

184

195

185decodeEither :: FromJSON a => ByteString -> Either String a

196decodeEither :: FromJSON a => ByteString -> Either String a

186decodeEither bs = unsafePerformIO

197decodeEither bs = unsafePerformIO

187 $ either (Left . prettyPrintParseException) id

198 $ either (Left . prettyPrintParseException) id

188− <$> decodeHelper (Y.decode bs)

199+ <$> (fmap snd <$> decodeHelper (Y.decode bs))

189{-# DEPRECATED decodeEither "Please use decodeEither' or decodeThrow, which provide more useful failures" #-}

200{-# DEPRECATED decodeEither "Please use decodeEither' or decodeThrow, which provide more useful failures" #-}

190

201

191-- | More helpful version of 'decodeEither' which returns the 'YamlException'.

202-- | More helpful version of 'decodeEither' which returns the 'YamlException'.

@@ -194,7 +205,7 @@ decodeEither bs = unsafePerformIO

194decodeEither' :: FromJSON a => ByteString -> Either ParseException a

205decodeEither' :: FromJSON a => ByteString -> Either ParseException a

195decodeEither' = either Left (either (Left . AesonException) Right)

206decodeEither' = either Left (either (Left . AesonException) Right)

196 . unsafePerformIO

207 . unsafePerformIO

197− . decodeHelper

208+ . fmap (fmap snd) . decodeHelper

198 . Y.decode

209 . Y.decode

199

210

200-- | A version of 'decodeEither'' lifted to MonadThrow

211-- | A version of 'decodeEither'' lifted to MonadThrow

src/Data/Yaml/Include.hs+18−4

@@ -1,6 +1,10 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE RankNTypes #-}

3−module Data.Yaml.Include (decodeFile, decodeFileEither) where

3+module Data.Yaml.Include (

4+ decodeFile

5+, decodeFileEither

6+, decodeFileWithWarnings

7+) where

5#if !MIN_VERSION_directory(1, 2, 3)

9#if !MIN_VERSION_directory(1, 2, 3)

6import Control.Exception (handleJust)

10import Control.Exception (handleJust)

@@ -20,7 +24,7 @@ import Data.Text.Encoding (decodeUtf8)

20import System.Directory

24import System.Directory

21import System.FilePath

25import System.FilePath

23−import Data.Yaml.Internal (ParseException(..), decodeHelper_, decodeHelper)

27+import Data.Yaml.Internal (ParseException(..), Warning(..), decodeHelper_, decodeHelper)

24import Text.Libyaml hiding (decodeFile)

28import Text.Libyaml hiding (decodeFile)

25import qualified Text.Libyaml as Y

29import qualified Text.Libyaml as Y

@@ -65,7 +69,7 @@ decodeFile

65 :: FromJSON a

69 :: FromJSON a

66 => FilePath

70 => FilePath

67 -> IO (Maybe a)

71 -> IO (Maybe a)

68−decodeFile fp = decodeHelper (eventsFromFile fp) >>= either throwIO (return . either (const Nothing) id)

72+decodeFile fp = (fmap snd <$> decodeHelper (eventsFromFile fp)) >>= either throwIO (return . either (const Nothing) id)

70-- | Like `Data.Yaml.decodeFileEither` but with support for relative and

74-- | Like `Data.Yaml.decodeFileEither` but with support for relative and

71-- absolute includes.

75-- absolute includes.

@@ -77,4 +81,14 @@ decodeFileEither

77 :: FromJSON a

81 :: FromJSON a

78 => FilePath

82 => FilePath

79 -> IO (Either ParseException a)

83 -> IO (Either ParseException a)

84+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings

85+

86+-- | A version of `decodeFileEither` that returns warnings along with the parse

87+-- result.

88+--

89+-- @since 0.10.0

90+decodeFileWithWarnings

91+ :: FromJSON a

92+ => FilePath

93+ -> IO (Either ParseException ([Warning], a))

80−decodeFileEither = decodeHelper_ . eventsFromFile

94+decodeFileWithWarnings = decodeHelper_ . eventsFromFile

src/Data/Yaml/Internal.hs+46−46

@@ -6,6 +6,7 @@ module Data.Yaml.Internal

6 (

7 ParseException(..)

8 , prettyPrintParseException

9+ , Warning(..)

9 , parse

10 , parse

10 , decodeHelper

11 , decodeHelper

11 , decodeHelper_

12 , decodeHelper_

@@ -19,23 +20,25 @@ import Control.Applicative ((<$>), Applicative(..))

19#endif

20#endif

20import Control.Applicative ((<|>))

21import Control.Applicative ((<|>))

21import Control.Exception

22import Control.Exception

22−import Control.Monad (liftM, ap, unless)

23+import Control.Monad (when, unless)

23−import Control.Monad.IO.Class (MonadIO, liftIO)

24−import Control.Monad.Trans.Class (MonadTrans, lift)

25import Control.Monad.Trans.Resource (ResourceT, runResourceT)

24import Control.Monad.Trans.Resource (ResourceT, runResourceT)

26−import Control.Monad.Trans.State

25+import Control.Monad.RWS

27import Data.Aeson

26import Data.Aeson

27+import Data.Aeson.Internal (JSONPath, JSONPathElement(..))

28import Data.Aeson.Types hiding (parse)

29import qualified Data.Attoparsec.Text as Atto

30import Data.Bits (shiftL, (.|.))

31import Data.ByteString (ByteString)

32import Data.Char (toUpper, ord)

33+import Data.List

33import Data.Conduit ((.|), ConduitM, runConduit)

34import Data.Conduit ((.|), ConduitM, runConduit)

34import qualified Data.Conduit.List as CL

35import qualified Data.Conduit.List as CL

35import qualified Data.HashMap.Strict as M

36import qualified Data.HashMap.Strict as M

36import qualified Data.HashSet as HashSet

37import qualified Data.HashSet as HashSet

37import Data.Map (Map)

38import Data.Map (Map)

38import qualified Data.Map as Map

39import qualified Data.Map as Map

40+import Data.Set (Set)

41+import qualified Data.Set as Set

39import Data.Scientific (Scientific)

42import Data.Scientific (Scientific)

40import Data.Text (Text, pack)

43import Data.Text (Text, pack)

41import qualified Data.Text as T

44import qualified Data.Text as T

@@ -109,31 +112,19 @@ prettyPrintParseException pe = case pe of

109 ]

112 ]

110 CyclicIncludes -> "Cyclic includes"

113 CyclicIncludes -> "Cyclic includes"

111

114

112−newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }

113−instance Monad m => Functor (PErrorT m) where

114− fmap = liftM

115−instance Monad m => Applicative (PErrorT m) where

116− pure = PErrorT . return . Right

117− (<*>) = ap

118−instance Monad m => Monad (PErrorT m) where

119− return = pure

120− (PErrorT m) >>= f = PErrorT $ do

121− e <- m

122− case e of

123− Left e' -> return $ Left e'

124− Right a -> runPErrorT $ f a

125−instance MonadTrans PErrorT where

126− lift = PErrorT . liftM Right

127−instance MonadIO m => MonadIO (PErrorT m) where

128− liftIO = lift . liftIO

129−

130defineAnchor :: Value -> String -> ConduitM e o Parse ()

115defineAnchor :: Value -> String -> ConduitM e o Parse ()

131−defineAnchor value name = lift $ modify $ Map.insert name value

116+defineAnchor value name = modify $ Map.insert name value

132

117

133lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)

118lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)

134−lookupAnchor name = lift $ gets (Map.lookup name)

119+lookupAnchor name = gets (Map.lookup name)

120+

121+data Warning = DuplicateKey JSONPath

122+ deriving (Eq, Show)

135

123

124+addWarning :: Warning -> ConduitM e o Parse ()

125+addWarning = tell . return

126+

136−type Parse = StateT (Map String Value) (ResourceT IO)

127+type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)

137

128

138requireEvent :: Event -> ConduitM Event o Parse ()

129requireEvent :: Event -> ConduitM Event o Parse ()

139requireEvent e = do

130requireEvent e = do

@@ -199,8 +190,8 @@ parseO = do

199 me <- CL.head

190 me <- CL.head

200 case me of

191 case me of

201 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag

192 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag

202− Just (EventSequenceStart _ _ a) -> parseS a id

193+ Just (EventSequenceStart _ _ a) -> parseS 0 a id

203− Just (EventMappingStart _ _ a) -> parseM a M.empty

194+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty

204 Just (EventAlias an) -> do

195 Just (EventAlias an) -> do

205 m <- lookupAnchor an

196 m <- lookupAnchor an

206 case m of

197 case m of

@@ -208,10 +199,11 @@ parseO = do

208 Just v -> return v

199 Just v -> return v

209 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing

200 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing

210

201

202+parseS :: Int

211−parseS :: Y.Anchor

203+ -> Y.Anchor

212 -> ([Value] -> [Value])

204 -> ([Value] -> [Value])

213 -> ConduitM Event o Parse Value

205 -> ConduitM Event o Parse Value

214−parseS a front = do

206+parseS n a front = do

215 me <- CL.peek

207 me <- CL.peek

216 case me of

208 case me of

217 Just EventSequenceEnd -> do

209 Just EventSequenceEnd -> do

@@ -220,13 +212,14 @@ parseS a front = do

220 mapM_ (defineAnchor res) a

212 mapM_ (defineAnchor res) a

221 return res

213 return res

222 _ -> do

214 _ -> do

223− o <- parseO

215+ o <- local (Index n :) parseO

224− parseS a $ front . (:) o

216+ parseS (succ n) a $ front . (:) o

225

217

218+parseM :: Set Text

226−parseM :: Y.Anchor

219+ -> Y.Anchor

227 -> M.HashMap Text Value

220 -> M.HashMap Text Value

228 -> ConduitM Event o Parse Value

221 -> ConduitM Event o Parse Value

229−parseM a front = do

222+parseM mergedKeys a front = do

230 me <- CL.head

223 me <- CL.head

231 case me of

224 case me of

232 Just EventMappingEnd -> do

225 Just EventMappingEnd -> do

@@ -243,48 +236,55 @@ parseM a front = do

243 Just (String t) -> return t

236 Just (String t) -> return t

244 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v

237 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v

245 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing

238 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing

246− o <- parseO

247

239

240+ (mergedKeys', al') <- local (Key s :) $ do

241+ o <- parseO

242+ let al = do

243+ when (M.member s front && Set.notMember s mergedKeys) $ do

244+ path <- reverse <$> ask

245+ addWarning (DuplicateKey path)

248− let al = M.insert s o front

246+ return (Set.delete s mergedKeys, M.insert s o front)

249− al' = if s == pack "<<"

247+ if s == pack "<<"

250 then case o of

248 then case o of

251− Object l -> M.union front l

249+ Object l -> return (merge l)

252− Array l -> M.union front $ foldl mergeObjects M.empty $ V.toList l

250+ Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l

253 _ -> al

251 _ -> al

254 else al

252 else al

255− parseM a al'

253+ parseM mergedKeys' a al'

256 where mergeObjects al (Object om) = M.union al om

254 where mergeObjects al (Object om) = M.union al om

257 mergeObjects al _ = al

255 mergeObjects al _ = al

258

256

257+ merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)

258+

259decodeHelper :: FromJSON a

260 => ConduitM () Y.Event Parse ()

261− -> IO (Either ParseException (Either String a))

261+ -> IO (Either ParseException ([Warning], Either String a))

262decodeHelper src = do

263 -- This used to be tryAny, but the fact is that catching async

264 -- exceptions is fine here. We'll rethrow them immediately in the

265 -- otherwise clause.

266− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse

266+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty

267 case x of

268 Left e

269 | Just pe <- fromException e -> return $ Left pe

270 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)

271 | otherwise -> throwIO e

272− Right y -> return $ Right $ parseEither parseJSON y

272+ Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y)

273

274decodeHelper_ :: FromJSON a

275 => ConduitM () Event Parse ()

276− -> IO (Either ParseException a)

276+ -> IO (Either ParseException ([Warning], a))

277decodeHelper_ src = do

278− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse

278+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty

279 return $ case x of

280 Left e

281 | Just pe <- fromException e -> Left pe

282 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)

283 | otherwise -> Left $ OtherParseException e

284− Right y -> either

284+ Right (y, warnings) -> either

285 (Left . AesonException)

286 Right

287− (parseEither parseJSON y)

287+ ((,) warnings <$> parseEither parseJSON y)

288

289-- | Strings which must be escaped so as not to be treated as non-string scalars.

290specialStrings :: HashSet.HashSet Text

test/Data/Yaml/IncludeSpec.hs+66

@@ -1,12 +1,18 @@

1+{-# LANGUAGE QuasiQuotes #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2module Data.Yaml.IncludeSpec (main, spec) where

3module Data.Yaml.IncludeSpec (main, spec) where

4import Test.Hspec

5import Test.Hspec

5import Data.List (isPrefixOf)

6import Data.List (isPrefixOf)

6import Data.Aeson

7import Data.Aeson

8+import Data.Aeson.Internal (JSONPathElement(..))

7import Data.Yaml (ParseException(InvalidYaml))

9import Data.Yaml (ParseException(InvalidYaml))

8import Data.Yaml.Include

10import Data.Yaml.Include

11+import Data.Yaml.Internal

9import Text.Libyaml (YamlException(YamlException))

12import Text.Libyaml (YamlException(YamlException))

13+import Test.Mockery.Directory

14+import Text.RawString.QQ

15+import Data.Yaml.TH (yamlQQ)

11main :: IO ()

17main :: IO ()

12main = hspec spec

18main = hspec spec

@@ -52,6 +58,66 @@ spec = do

52 (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>=

58 (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>=

53 (`shouldSatisfy` either isYamlFileNotFoundException (const False))

59 (`shouldSatisfy` either isYamlFileNotFoundException (const False))

61+ describe "decodeFileWithWarnings" $ around_ inTempDirectory $ do

62+ it "warns on duplicate keys" $ do

63+ writeFile "foo.yaml" [r|

64+ foo: 23

65+ foo: bar

66+ |]

67+ Right result <- decodeFileWithWarnings "foo.yaml"

68+ result `shouldBe` ([DuplicateKey [Key "foo"]], [yamlQQ|

69+ foo: bar

70+ |])

71+

72+ it "warns on nested duplicate keys" $ do

73+ writeFile "foo.yaml" [r|

74+ foo:

75+ - 42

76+ - bar: 23

77+ bar: baz

78+ |]

79+ Right result <- decodeFileWithWarnings "foo.yaml"

80+ result `shouldBe` ([DuplicateKey [Key "foo", Index 1, Key "bar"]], [yamlQQ|

81+ foo:

82+ - 42

83+ - bar: baz

84+ |])

85+

86+ context "when overriding a merged key" $ do

87+ it "does not warn" $ do

88+ writeFile "foo.yaml" [r|

89+ foo-1: &my-ref

90+ bar: 23

91+ foo-2:

92+ <<: *my-ref

93+ bar: 42

94+ |]

95+ Right result <- decodeFileWithWarnings "foo.yaml"

96+ result `shouldBe` ([], [yamlQQ|

97+ foo-1:

98+ bar: 23

99+ foo-2:

100+ bar: 42

101+ |])

102+

103+ context "when overriding twice" $ do

104+ it "warns" $ do

105+ writeFile "foo.yaml" [r|

106+ foo-1: &my-ref

107+ bar: 23

108+ foo-2:

109+ <<: *my-ref

110+ bar: 42

111+ bar: 65

112+ |]

113+ Right result <- decodeFileWithWarnings "foo.yaml"

114+ result `shouldBe` ([DuplicateKey [Key "foo-2", Key "bar"]], [yamlQQ|

115+ foo-1:

116+ bar: 23

117+ foo-2:

118+ bar: 65

119+ |])

120+

55isYamlFileNotFoundException :: ParseException -> Bool

121isYamlFileNotFoundException :: ParseException -> Bool

56isYamlFileNotFoundException (InvalidYaml (Just (YamlException msg)))

122isYamlFileNotFoundException (InvalidYaml (Just (YamlException msg)))

57 | "Yaml file not found: " `isPrefixOf` msg = True

123 | "Yaml file not found: " `isPrefixOf` msg = True