7bfbda7 · typeable/aeson

Data/Aeson/Types.hs+1

compare with master

unifiedsplit

@@ -32,6 +32,7 @@ module Data.Aeson.Types

32 , parseEither

33 , parseMaybe

34 , ToJSON(..)

35+ , modifyFailure

35

36

36 -- * Inspecting @'Value's@

37 -- * Inspecting @'Value's@

37 , withObject

38 , withObject

Data/Aeson/Types/Internal.hs+16

@@ -26,6 +26,7 @@ module Data.Aeson.Types.Internal

26 , parse

27 , parseEither

28 , parseMaybe

29+ , modifyFailure

29 -- * Constructors and accessors

30 -- * Constructors and accessors

30 , object

31 , object

31 ) where

32 ) where

@@ -225,3 +226,18 @@ type Pair = (Text, Value)

225object :: [Pair] -> Value

226object :: [Pair] -> Value

226object = Object . H.fromList

227object = Object . H.fromList

227{-# INLINE object #-}

228{-# INLINE object #-}

229+

230+-- | If the inner @Parser@ failed, modify the failure message using the

231+-- provided function. This allows you to create more meaningful error messages.

232+-- For example:

233+--

234+-- > parseJSON (Object o) = modifyFailure

235+-- > ("Parsing of the Foo value failed: " ++)

236+-- > (Foo <$> o .: "someField")

237+--

238+-- Since 0.6.2.0

239+modifyFailure :: (String -> String) -> Parser a -> Parser a

240+modifyFailure f (Parser p) =

241+ Parser $ \failure success -> p (modifyFailure' failure) success

242+ where

243+ modifyFailure' failure original = failure $ f original

tests/Properties.hs+11

@@ -66,6 +66,14 @@ regress_gh72 :: [(String, Maybe String)] -> Bool

66regress_gh72 ys = G.decode (G.encode m) == Just m

67 where m = Map.fromList ys

68

69+modifyFailureProp :: String -> String -> Bool

70+modifyFailureProp orig added =

71+ result == Error (added ++ orig)

72+ where

73+ parser = const $ modifyFailure (added ++) $ fail orig

74+ result :: Result ()

75+ result = parse parser ()

76+

69data Foo = Foo {

77data Foo = Foo {

70 fooInt :: Int

78 fooInt :: Int

71 , fooDouble :: Double

79 , fooDouble :: Double

@@ -169,5 +177,8 @@ tests = [

169 ],

177 ],

170 testGroup "genericToFromJSON" [

178 testGroup "genericToFromJSON" [

171 testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool)

179 testProperty "_UFoo" (genericToFromJSON :: UFoo -> Bool)

180+ ],

181+ testGroup "failure messages" [

182+ testProperty "modify failure" modifyFailureProp

172 ]

183 ]

173 ]

184 ]