master...7bcf368 · typeable/aeson

git.iko.soy/typeable/aeson

on 7bcf368 help sign in

Data/Aeson.hs+40−2

since splitsnapshots

unifiedsplit

@@ -37,12 +37,16 @@ module Data.Aeson

37 , decode'

38 , eitherDecode

39 , eitherDecode'

40+ , verboseDecode

41+ , verboseDecode'

40 , encode

42 , encode

41 -- ** Variants for strict bytestrings

43 -- ** Variants for strict bytestrings

42 , decodeStrict

44 , decodeStrict

43 , decodeStrict'

45 , decodeStrict'

44 , eitherDecodeStrict

46 , eitherDecodeStrict

45 , eitherDecodeStrict'

47 , eitherDecodeStrict'

48+ , verboseDecodeStrict

49+ , verboseDecodeStrict'

46 -- * Core JSON types

50 -- * Core JSON types

47 , Value(..)

51 , Value(..)

48 , Encoding

52 , Encoding

@@ -131,9 +135,14 @@ import Prelude.Compat

131

135

132import Data.Aeson.Types.FromJSON (ifromJSON)

136import Data.Aeson.Types.FromJSON (ifromJSON)

133import Data.Aeson.Encoding (encodingToLazyByteString)

137import Data.Aeson.Encoding (encodingToLazyByteString)

138+import Data.Aeson.Parser.Internal

139+ ( decodeWith, decodeStrictWith

134−import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')

140+ , eitherDecodeWith, eitherDecodeStrictWith

141+ , verboseDecodeWith, verboseDecodeStrictWith

142+ , jsonEOF, json, jsonEOF', json')

135import Data.Aeson.Types

143import Data.Aeson.Types

136−import Data.Aeson.Types.Internal (JSONPath, formatError)

144+import Data.Aeson.Types.Internal (JSONPath, formatError, formatErrors)

145+import Data.List.NonEmpty (NonEmpty)

137import qualified Data.ByteString as B

146import qualified Data.ByteString as B

138import qualified Data.ByteString.Lazy as L

147import qualified Data.ByteString.Lazy as L

139

148

@@ -221,6 +230,35 @@ eitherDecodeStrict' =

221 eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON

230 eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON

222{-# INLINE eitherDecodeStrict' #-}

231{-# INLINE eitherDecodeStrict' #-}

223

232

233+eitherFormatErrors

234+ :: Either (NonEmpty (JSONPath, String)) a -> Either (NonEmpty String) a

235+eitherFormatErrors = either (Left . formatErrors) Right

236+{-# INLINE eitherFormatErrors #-}

237+

238+-- | Like 'decode' but returns one or more error messages when decoding fails.

239+verboseDecode :: (FromJSON a) => L.ByteString -> Either (NonEmpty String) a

240+verboseDecode = eitherFormatErrors . verboseDecodeWith jsonEOF ifromJSON

241+{-# INLINE verboseDecode #-}

242+

243+-- | Like 'decodeStrict' but returns one or more error messages when decoding

244+-- fails.

245+verboseDecodeStrict :: (FromJSON a) => B.ByteString -> Either (NonEmpty String) a

246+verboseDecodeStrict =

247+ eitherFormatErrors . verboseDecodeStrictWith jsonEOF ifromJSON

248+{-# INLINE verboseDecodeStrict #-}

249+

250+-- | Like 'decode'' but returns one or more error messages when decoding fails.

251+verboseDecode' :: (FromJSON a) => L.ByteString -> Either (NonEmpty String) a

252+verboseDecode' = eitherFormatErrors . verboseDecodeWith jsonEOF' ifromJSON

253+{-# INLINE verboseDecode' #-}

254+

255+-- | Like 'decodeStrict'' but returns one or more error messages when decoding

256+-- fails.

257+verboseDecodeStrict' :: (FromJSON a) => B.ByteString -> Either (NonEmpty String) a

258+verboseDecodeStrict' =

259+ eitherFormatErrors . verboseDecodeStrictWith jsonEOF' ifromJSON

260+{-# INLINE verboseDecodeStrict' #-}

261+

224-- $use

262-- $use

225--

263--

226-- This section contains basic information on the different ways to

264-- This section contains basic information on the different ways to

Data/Aeson/AccParser.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+module Data.Aeson.AccParser

4+ (

5+ AccParser (AccParser, getParser)

6+ , accSequence

7+ , accTraverse

8+ , (<*>+)

9+ ) where

10+

11+import Data.Aeson.Types.Internal (Parser (..), runParser)

12+import Data.List.NonEmpty (NonEmpty ((:|)))

13+import qualified Data.List.NonEmpty as NonEmpty

14+

15+newtype AccParser a = AccParser { getParser :: Parser a }

16+ deriving Functor

17+

18+instance Applicative AccParser where

19+ pure = AccParser . pure

20+ f <*> a = AccParser (getParser f <*>+ getParser a)

21+

22+-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors

23+-- from both subparsers.

24+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c

25+liftP2 f pa pb = Parser $ \path kf ks ->

26+ runParser pa path

27+ (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))

28+ (\a -> runParser pb path kf (\b -> ks (f a b)))

29+{-# INLINE liftP2 #-}

30+

31+accSequence :: Traversable t => t (Parser a) -> Parser (t a)

32+accSequence = accTraverse id

33+

34+accTraverse :: Traversable t => (a -> Parser b) -> t a -> Parser (t b)

35+accTraverse f s = getParser $ traverse' (AccParser . f) s

36+

37+-- Making sure we are using Applicative AccParser

38+traverse' :: Traversable t => (a -> AccParser b) -> t a -> AccParser (t b)

39+traverse' = traverse

40+

41+infixl 4 <*>+

42+

43+-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.

44+(<*>+) :: Parser (a -> b) -> Parser a -> Parser b

45+(<*>+) = liftP2 id

46+{-# INLINE (<*>+) #-}

Data/Aeson/Internal.hs+1

@@ -18,6 +18,7 @@ module Data.Aeson.Internal

18 , JSONPath

19 , (<?>)

20 , formatError

21+ , formatErrors

21 , ifromJSON

22 , ifromJSON

22 , iparse

23 , iparse

23 ) where

24 ) where

Data/Aeson/Parser/Internal.hs+26−5

@@ -33,6 +33,8 @@ module Data.Aeson.Parser.Internal

33 , decodeStrictWith

34 , eitherDecodeWith

35 , eitherDecodeStrictWith

36+ , verboseDecodeWith

37+ , verboseDecodeStrictWith

36 ) where

38 ) where

38import Prelude ()

40import Prelude ()

@@ -42,6 +44,7 @@ import Control.Applicative ((<|>))

42import Control.Monad (void, when)

44import Control.Monad (void, when)

43import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

45import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

44import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

46import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

47+import Data.List.NonEmpty (NonEmpty((:|)))

45import Data.Scientific (Scientific)

48import Data.Scientific (Scientific)

46import Data.Text (Text)

49import Data.Text (Text)

47import Data.Vector as Vector (Vector, empty, fromListN, reverse)

50import Data.Vector as Vector (Vector, empty, fromListN, reverse)

@@ -274,19 +277,37 @@ eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString

274eitherDecodeWith p to s =

277eitherDecodeWith p to s =

275 case L.parse p s of

278 case L.parse p s of

276 L.Done _ v -> case to v of

279 L.Done _ v -> case to v of

277− ISuccess a -> Right a

280+ ISuccess a -> Right a

278− IError path msg -> Left (path, msg)

281+ IError (e :| _) -> Left e

279 L.Fail _ _ msg -> Left ([], msg)

282 L.Fail _ _ msg -> Left ([], msg)

280{-# INLINE eitherDecodeWith #-}

283{-# INLINE eitherDecodeWith #-}

281

284

282eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

285eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

283 -> Either (JSONPath, String) a

286 -> Either (JSONPath, String) a

284eitherDecodeStrictWith p to s =

287eitherDecodeStrictWith p to s =

285− case either (IError []) to (A.parseOnly p s) of

288+ case either (\e -> IError (([], e) :| [])) to (A.parseOnly p s) of

286− ISuccess a -> Right a

289+ ISuccess a -> Right a

287− IError path msg -> Left (path, msg)

290+ IError (e :| _) -> Left e

288{-# INLINE eitherDecodeStrictWith #-}

291{-# INLINE eitherDecodeStrictWith #-}

289

292

293+verboseDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString

294+ -> Either (NonEmpty (JSONPath, String)) a

295+verboseDecodeWith p to s =

296+ case L.parse p s of

297+ L.Done _ v -> case to v of

298+ ISuccess a -> Right a

299+ IError e -> Left e

300+ L.Fail _ _ msg -> Left (([], msg) :| [])

301+{-# INLINE verboseDecodeWith #-}

302+

303+verboseDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

304+ -> Either (NonEmpty (JSONPath, String)) a

305+verboseDecodeStrictWith p to s =

306+ case either (\e -> IError (([], e) :| [])) to (A.parseOnly p s) of

307+ ISuccess a -> Right a

308+ IError e -> Left e

309+{-# INLINE verboseDecodeStrictWith #-}

310+

290-- $lazy

311-- $lazy

291--

312--

292-- The 'json' and 'value' parsers decouple identification from

313-- The 'json' and 'value' parsers decouple identification from

Data/Aeson/Types.hs+1

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

38 , modifyFailure

39 , parserThrowError

40 , parserCatchError

41+ , parserCatchErrors

42 -- ** Keys for maps

43 -- ** Keys for maps

43 , ToJSONKey(..)

44 , ToJSONKey(..)

Data/Aeson/Types/FromJSON.hs+7−6

@@ -86,6 +86,7 @@ import Data.Aeson.Internal.Functions (mapKey)

86import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)

87import Data.Aeson.Types.Generic

88import Data.Aeson.Types.Internal

89+import Data.Aeson.AccParser

89import Data.Attoparsec.Number (Number(..))

90import Data.Attoparsec.Number (Number(..))

90import Data.Bits (unsafeShiftR)

91import Data.Bits (unsafeShiftR)

91import Data.Fixed (Fixed, HasResolution)

92import Data.Fixed (Fixed, HasResolution)

@@ -164,8 +165,8 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx

164 p = withArray "(k,v)" $ \ab ->

165 p = withArray "(k,v)" $ \ab ->

165 let n = V.length ab

166 let n = V.length ab

166 in if n == 2

167 in if n == 2

167− then (,) <$> parseJSONElemAtIndex keyParser 0 ab

168+ then (,) <$> parseJSONElemAtIndex keyParser 0 ab

168− <*> parseJSONElemAtIndex valParser 1 ab

169+ <*>+ parseJSONElemAtIndex valParser 1 ab

169 else fail $ "cannot unpack array of length " ++

170 else fail $ "cannot unpack array of length " ++

170 show n ++ " into a pair"

171 show n ++ " into a pair"

171{-# INLINE parseIndexedJSONPair #-}

172{-# INLINE parseIndexedJSONPair #-}

@@ -606,7 +607,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList

606

607

607-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.

608-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.

608listParser :: (Value -> Parser a) -> Value -> Parser [a]

609listParser :: (Value -> Parser a) -> Value -> Parser [a]

609−listParser f (Array xs) = fmap V.toList (V.mapM f xs)

610+listParser f (Array xs) = getParser $ V.toList <$> traverse (AccParser . f) xs

610listParser _ v = typeMismatch "[a]" v

611listParser _ v = typeMismatch "[a]" v

611{-# INLINE listParser #-}

612{-# INLINE listParser #-}

612

613

@@ -1413,7 +1414,7 @@ parseVersionText = go . readP_to_S parseVersion . unpack

1413

1414

1414instance FromJSON1 NonEmpty where

1415instance FromJSON1 NonEmpty where

1415 liftParseJSON p _ = withArray "NonEmpty a" $

1416 liftParseJSON p _ = withArray "NonEmpty a" $

1416− (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1417+ (>>= ne) . accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1417 where

1418 where

1418 ne [] = fail "Expected a NonEmpty but got an empty list"

1419 ne [] = fail "Expected a NonEmpty but got an empty list"

1419 ne (x:xs) = pure (x :| xs)

1420 ne (x:xs) = pure (x :| xs)

@@ -1529,7 +1530,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where

1529instance FromJSON1 Seq.Seq where

1530instance FromJSON1 Seq.Seq where

1530 liftParseJSON p _ = withArray "Seq a" $

1531 liftParseJSON p _ = withArray "Seq a" $

1531 fmap Seq.fromList .

1532 fmap Seq.fromList .

1532− Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1533+ accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1533 {-# INLINE liftParseJSON #-}

1534 {-# INLINE liftParseJSON #-}

1534

1535

1535instance (FromJSON a) => FromJSON (Seq.Seq a) where

1536instance (FromJSON a) => FromJSON (Seq.Seq a) where

@@ -1607,7 +1608,7 @@ instance FromJSONKey UUID.UUID where

1607

1608

1608instance FromJSON1 Vector where

1609instance FromJSON1 Vector where

1609 liftParseJSON p _ = withArray "Vector a" $

1610 liftParseJSON p _ = withArray "Vector a" $

1610− V.mapM (uncurry $ parseIndexedJSON p) . V.indexed

1611+ accTraverse (uncurry $ parseIndexedJSON p) . V.indexed

1611 {-# INLINE liftParseJSON #-}

1612 {-# INLINE liftParseJSON #-}

1612

1613

1613instance (FromJSON a) => FromJSON (Vector a) where

1614instance (FromJSON a) => FromJSON (Vector a) where

Data/Aeson/Types/Internal.hs+37−22

@@ -34,7 +34,8 @@ module Data.Aeson.Types.Internal

34 , emptyObject

36 -- * Type conversion

37− , Parser

37+ , Parser (Parser)

38+ , runParser

38 , Result(..)

39 , Result(..)

39 , IResult(..)

40 , IResult(..)

40 , JSONPathElement(..)

41 , JSONPathElement(..)

@@ -46,7 +47,9 @@ module Data.Aeson.Types.Internal

46 , modifyFailure

47 , modifyFailure

47 , parserThrowError

48 , parserThrowError

48 , parserCatchError

49 , parserCatchError

50+ , parserCatchErrors

49 , formatError

51 , formatError

52+ , formatErrors

50 , (<?>)

53 , (<?>)

51 -- * Constructors and accessors

54 -- * Constructors and accessors

52 , object

55 , object

@@ -87,6 +90,7 @@ import Data.Foldable (foldl')

87import Data.HashMap.Strict (HashMap)

90import Data.HashMap.Strict (HashMap)

88import Data.Hashable (Hashable(..))

91import Data.Hashable (Hashable(..))

89import Data.List (intercalate)

92import Data.List (intercalate)

93+import Data.List.NonEmpty (NonEmpty((:|)))

90import Data.Scientific (Scientific)

94import Data.Scientific (Scientific)

91import Data.Semigroup (Semigroup((<>)))

95import Data.Semigroup (Semigroup((<>)))

92import Data.String (IsString(..))

96import Data.String (IsString(..))

@@ -98,6 +102,7 @@ import Data.Vector (Vector)

98import GHC.Generics (Generic)

102import GHC.Generics (Generic)

99import qualified Control.Monad.Fail as Fail

103import qualified Control.Monad.Fail as Fail

100import qualified Data.HashMap.Strict as H

104import qualified Data.HashMap.Strict as H

105+import qualified Data.List.NonEmpty as NonEmpty

101import qualified Data.Scientific as S

106import qualified Data.Scientific as S

102import qualified Data.Vector as V

107import qualified Data.Vector as V

103import qualified Language.Haskell.TH.Syntax as TH

108import qualified Language.Haskell.TH.Syntax as TH

@@ -118,7 +123,7 @@ data JSONPathElement = Key Text

118type JSONPath = [JSONPathElement]

123type JSONPath = [JSONPathElement]

119

124

120-- | The internal result of running a 'Parser'.

125-- | The internal result of running a 'Parser'.

121−data IResult a = IError JSONPath String

126+data IResult a = IError (NonEmpty (JSONPath, String))

122 | ISuccess a

127 | ISuccess a

123 deriving (Eq, Show, Typeable)

128 deriving (Eq, Show, Typeable)

124

129

@@ -133,15 +138,15 @@ instance NFData JSONPathElement where

133

138

134instance (NFData a) => NFData (IResult a) where

139instance (NFData a) => NFData (IResult a) where

135 rnf (ISuccess a) = rnf a

140 rnf (ISuccess a) = rnf a

136− rnf (IError path err) = rnf path `seq` rnf err

141+ rnf (IError err) = rnf err

137

142

138instance (NFData a) => NFData (Result a) where

143instance (NFData a) => NFData (Result a) where

139 rnf (Success a) = rnf a

144 rnf (Success a) = rnf a

140 rnf (Error err) = rnf err

145 rnf (Error err) = rnf err

141

146

142instance Functor IResult where

147instance Functor IResult where

143− fmap f (ISuccess a) = ISuccess (f a)

148+ fmap f (ISuccess a) = ISuccess (f a)

144− fmap _ (IError path err) = IError path err

149+ fmap _ (IError err) = IError err

145 {-# INLINE fmap #-}

150 {-# INLINE fmap #-}

146

151

147instance Functor Result where

152instance Functor Result where

@@ -153,15 +158,15 @@ instance Monad IResult where

153 return = pure

158 return = pure

154 {-# INLINE return #-}

159 {-# INLINE return #-}

155

160

156− ISuccess a >>= k = k a

161+ ISuccess a >>= k = k a

157− IError path err >>= _ = IError path err

162+ IError err >>= _ = IError err

158 {-# INLINE (>>=) #-}

163 {-# INLINE (>>=) #-}

159

164

160 fail = Fail.fail

165 fail = Fail.fail

161 {-# INLINE fail #-}

166 {-# INLINE fail #-}

162

167

163instance Fail.MonadFail IResult where

168instance Fail.MonadFail IResult where

164− fail err = IError [] err

169+ fail err = IError (([], err) :| [])

165 {-# INLINE fail #-}

170 {-# INLINE fail #-}

166

171

167instance Monad Result where

172instance Monad Result where

@@ -238,11 +243,11 @@ instance Monoid (Result a) where

238 {-# INLINE mappend #-}

243 {-# INLINE mappend #-}

239

244

240instance Foldable IResult where

245instance Foldable IResult where

241− foldMap _ (IError _ _) = mempty

246+ foldMap _ (IError _) = mempty

242 foldMap f (ISuccess y) = f y

247 foldMap f (ISuccess y) = f y

243 {-# INLINE foldMap #-}

248 {-# INLINE foldMap #-}

244

249

245− foldr _ z (IError _ _) = z

250+ foldr _ z (IError _) = z

246 foldr f z (ISuccess y) = f y z

251 foldr f z (ISuccess y) = f y z

247 {-# INLINE foldr #-}

252 {-# INLINE foldr #-}

248

253

@@ -256,8 +261,8 @@ instance Foldable Result where

256 {-# INLINE foldr #-}

261 {-# INLINE foldr #-}

257

262

258instance Traversable IResult where

263instance Traversable IResult where

259− traverse _ (IError path err) = pure (IError path err)

264+ traverse _ (IError err) = pure (IError err)

260− traverse f (ISuccess a) = ISuccess <$> f a

265+ traverse f (ISuccess a) = ISuccess <$> f a

261 {-# INLINE traverse #-}

266 {-# INLINE traverse #-}

262

267

263instance Traversable Result where

268instance Traversable Result where

@@ -266,7 +271,7 @@ instance Traversable Result where

266 {-# INLINE traverse #-}

271 {-# INLINE traverse #-}

267

272

268-- | Failure continuation.

273-- | Failure continuation.

269−type Failure f r = JSONPath -> String -> f r

274+type Failure f r = NonEmpty (JSONPath, String) -> f r

270-- | Success continuation.

275-- | Success continuation.

271type Success a f r = a -> f r

276type Success a f r = a -> f r

272

277

@@ -289,7 +294,7 @@ instance Monad Parser where

289 {-# INLINE fail #-}

294 {-# INLINE fail #-}

290

295

291instance Fail.MonadFail Parser where

296instance Fail.MonadFail Parser where

292− fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

297+ fail msg = Parser $ \path kf _ks -> kf ((reverse path, msg) :| [])

293 {-# INLINE fail #-}

298 {-# INLINE fail #-}

294

299

295instance Functor Parser where

300instance Functor Parser where

@@ -309,10 +314,11 @@ instance Alternative Parser where

309 (<|>) = mplus

314 (<|>) = mplus

310 {-# INLINE (<|>) #-}

315 {-# INLINE (<|>) #-}

311

316

317+{- TODO accumulate errors -}

312instance MonadPlus Parser where

318instance MonadPlus Parser where

313 mzero = fail "mzero"

319 mzero = fail "mzero"

314 {-# INLINE mzero #-}

320 {-# INLINE mzero #-}

315− mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks

321+ mplus a b = Parser $ \path kf ks -> let kf' _ = runParser b path kf ks

316 in runParser a path kf' ks

322 in runParser a path kf' ks

317 {-# INLINE mplus #-}

323 {-# INLINE mplus #-}

318

324

@@ -423,7 +429,7 @@ emptyObject = Object H.empty

423

429

424-- | Run a 'Parser'.

430-- | Run a 'Parser'.

425parse :: (a -> Parser b) -> a -> Result b

431parse :: (a -> Parser b) -> a -> Result b

426−parse m v = runParser (m v) [] (const Error) Success

432+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success

427{-# INLINE parse #-}

433{-# INLINE parse #-}

428

434

429-- | Run a 'Parser'.

435-- | Run a 'Parser'.

@@ -433,14 +439,14 @@ iparse m v = runParser (m v) [] IError ISuccess

433

439

434-- | Run a 'Parser' with a 'Maybe' result type.

440-- | Run a 'Parser' with a 'Maybe' result type.

435parseMaybe :: (a -> Parser b) -> a -> Maybe b

441parseMaybe :: (a -> Parser b) -> a -> Maybe b

436−parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just

442+parseMaybe m v = runParser (m v) [] (const Nothing) Just

437{-# INLINE parseMaybe #-}

443{-# INLINE parseMaybe #-}

438

444

439-- | Run a 'Parser' with an 'Either' result type. If the parse fails,

445-- | Run a 'Parser' with an 'Either' result type. If the parse fails,

440-- the 'Left' payload will contain an error message.

446-- the 'Left' payload will contain an error message.

441parseEither :: (a -> Parser b) -> a -> Either String b

447parseEither :: (a -> Parser b) -> a -> Either String b

442parseEither m v = runParser (m v) [] onError Right

448parseEither m v = runParser (m v) [] onError Right

443− where onError path msg = Left (formatError path msg)

449+ where onError ((path, err) :| _) = Left (formatError path err)

444{-# INLINE parseEither #-}

450{-# INLINE parseEither #-}

445

451

446-- | Annotate an error message with a

452-- | Annotate an error message with a

@@ -471,6 +477,10 @@ formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg

471 escapeChar '\\' = "\\\\"

477 escapeChar '\\' = "\\\\"

472 escapeChar c = [c]

478 escapeChar c = [c]

473

479

480+-- | Annotate a list of error messages.

481+formatErrors :: Functor f => f (JSONPath, String) -> f String

482+formatErrors = fmap (uncurry formatError)

483+

474-- | A key\/value pair for an 'Object'.

484-- | A key\/value pair for an 'Object'.

475type Pair = (Text, Value)

485type Pair = (Text, Value)

476

486

@@ -510,21 +520,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks

510-- Since 0.6.2.0

520-- Since 0.6.2.0

511modifyFailure :: (String -> String) -> Parser a -> Parser a

521modifyFailure :: (String -> String) -> Parser a -> Parser a

512modifyFailure f (Parser p) = Parser $ \path kf ks ->

522modifyFailure f (Parser p) = Parser $ \path kf ks ->

513− p path (\p' m -> kf p' (f m)) ks

523+ p path (\m -> kf ((fmap . fmap) f m)) ks

514

524

515-- | Throw a parser error with an additional path.

525-- | Throw a parser error with an additional path.

516--

526--

517-- @since 1.2.1.0

527-- @since 1.2.1.0

518parserThrowError :: JSONPath -> String -> Parser a

528parserThrowError :: JSONPath -> String -> Parser a

519parserThrowError path' msg = Parser $ \path kf _ks ->

529parserThrowError path' msg = Parser $ \path kf _ks ->

520− kf (reverse path ++ path') msg

530+ kf ((reverse path ++ path', msg) :| [])

521

531

522-- | A handler function to handle previous errors and return to normal execution.

532-- | A handler function to handle previous errors and return to normal execution.

523--

533--

524-- @since 1.2.1.0

534-- @since 1.2.1.0

525parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a

535parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a

536+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)

537+

538+-- | A handler function to handle multiple previous errors and return to normal

539+-- execution.

540+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a

526−parserCatchError (Parser p) handler = Parser $ \path kf ks ->

541+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->

527− p path (\e msg -> runParser (handler e msg) path kf ks) ks

542+ p path (\es -> runParser (handler es) path kf ks) ks

528

543

529--------------------------------------------------------------------------------

544--------------------------------------------------------------------------------

530-- Generic and TH encoding configuration

545-- Generic and TH encoding configuration

aeson.cabal+2

@@ -84,6 +84,7 @@ library

85 exposed-modules:

86 Data.Aeson

87+ Data.Aeson.AccParser

87 Data.Aeson.Encoding

88 Data.Aeson.Encoding

88 Data.Aeson.Parser

89 Data.Aeson.Parser

89 Data.Aeson.Text

90 Data.Aeson.Text

@@ -196,6 +197,7 @@ test-suite tests

196 SerializationFormatSpec

197 SerializationFormatSpec

197 Types

198 Types

198 UnitTests

199 UnitTests

200+ UnitTests.AccErrors

199 UnitTests.NullaryConstructors

201 UnitTests.NullaryConstructors

200

202

201 build-depends:

203 build-depends:

examples/Simplest.hs+7−3

@@ -8,6 +8,7 @@ import Prelude.Compat

9import Control.Applicative (empty)

10import Data.Aeson

11+import Data.Aeson.Types

11import Data.Monoid

12import Data.Monoid

12import qualified Data.ByteString.Lazy.Char8 as BL

13import qualified Data.ByteString.Lazy.Char8 as BL

@@ -28,9 +29,9 @@ instance ToJSON Coord where

28-- should match the format used by the ToJSON instance.

29-- should match the format used by the ToJSON instance.

30instance FromJSON Coord where

31instance FromJSON Coord where

31− parseJSON (Object v) = Coord <$>

32+ parseJSON (Object v) = liftP2 Coord

32− v .: "x" <*>

33+ (v .: "x")

33− v .: "y"

34+ (v .: "y")

34 parseJSON _ = empty

35 parseJSON _ = empty

36main :: IO ()

37main :: IO ()

@@ -39,3 +40,6 @@ main = do

39 print req

40 print req

40 let reply = Coord 123.4 20

41 let reply = Coord 123.4 20

41 BL.putStrLn (encode reply)

42 BL.putStrLn (encode reply)

43+ let asCoord :: f Coord -> f Coord

44+ asCoord = id

45+ print (asCoord (verboseDecode "{}"))

tests/Properties.hs+7−7

@@ -21,7 +21,7 @@ import Data.Functor.Compose (Compose (..))

21import Data.HashMap.Strict (HashMap)

22import Data.Hashable (Hashable)

23import Data.Int (Int8)

24−import Data.List.NonEmpty (NonEmpty)

24+import Data.List.NonEmpty (NonEmpty((:|)))

25import Data.Map (Map)

26import Data.Proxy (Proxy)

27import Data.Ratio (Ratio)

@@ -59,8 +59,8 @@ toParseJSON :: (Eq a, Show a) =>

59 (Value -> Parser a) -> (a -> Value) -> a -> Property

60toParseJSON parsejson tojson x =

61 case iparse parsejson . tojson $ x of

62− IError path msg -> failure "parse" (formatError path msg) x

62+ IError ((path, msg) :| _) -> failure "parse" (formatError path msg) x

63− ISuccess x' -> x === x'

63+ ISuccess x' -> x === x'

65toParseJSON1

66 :: (Eq (f Int), Show (f Int))

@@ -78,15 +78,15 @@ roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>

78roundTripEnc eq _ i =

79 case fmap ifromJSON . L.parse value . encode $ i of

80 L.Done _ (ISuccess v) -> v `eq` i

81− L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i

81+ L.Done _ (IError ((path, err) :| _)) -> failure "fromJSON" (formatError path err) i

82 L.Fail _ _ err -> failure "parse" err i

84roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>

85 (a -> a -> Property) -> a -> a -> Property

86roundTripNoEnc eq _ i =

87 case ifromJSON . toJSON $ i of

88− (ISuccess v) -> v `eq` i

88+ ISuccess v -> v `eq` i

89− (IError path err) -> failure "fromJSON" (formatError path err) i

89+ IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) i

91roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property

92roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y

@@ -104,7 +104,7 @@ x ==~ y =

104

105toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property

106toFromJSON x = case ifromJSON (toJSON x) of

107− IError path err -> failure "fromJSON" (formatError path err) x

107+ IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) x

108 ISuccess x' -> x === x'

109

110modifyFailureProp :: String -> String -> Bool

tests/Tests.hs+8−1

@@ -7,8 +7,15 @@ import Test.Framework (defaultMain)

7import qualified DataFamilies.Properties as DF

8import qualified Properties

9import qualified UnitTests

10+import qualified UnitTests.AccErrors as AccErrors

11main :: IO ()

12main :: IO ()

12main = do

13main = do

13 ioTests <- UnitTests.ioTests

14 ioTests <- UnitTests.ioTests

15+ defaultMain

16+ ( AccErrors.tests

17+ : DF.tests

14− defaultMain (DF.tests : Properties.tests : UnitTests.tests : ioTests)

18+ : Properties.tests

19+ : UnitTests.tests

20+ : ioTests

21+ )

tests/UnitTests/AccErrors.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# LANGUAGE NoMonomorphismRestriction #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module UnitTests.AccErrors (tests) where

5+import Prelude ()

6+import Prelude.Compat hiding (seq)

8+import Data.Aeson

9+import Data.Aeson.Parser.Internal

10+import Data.Aeson.Types ()

11+import Data.Aeson.Internal

12+import Data.List.NonEmpty (NonEmpty)

13+import Data.Semigroup

14+import Data.Vector (Vector)

15+import Test.Framework

16+import Test.Framework.Providers.HUnit

17+import Test.HUnit hiding (Test)

18+import qualified Data.ByteString.Lazy as L

19+import qualified Data.List.NonEmpty as NL

20+import qualified Data.Sequence as Seq

21+

22+tests :: Test

23+tests = testGroup "Error accumulation" [

24+ testCase "Seq" seq

25+ , testCase "Vector" vector

26+ , testCase "NonEmpty" nonEmpty

27+ ]

28+

29+decoder :: FromJSON a

30+ => L.ByteString

31+ -> Either (NonEmpty (JSONPath, String)) a

32+decoder = verboseDecodeWith jsonEOF ifromJSON

33+

34+seq :: Assertion

35+seq = do

36+ let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (Seq.Seq Int)

37+ let message i s = ([Index i], "expected Int, encountered " <> s)

38+ res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])

39+

40+vector :: Assertion

41+vector = do

42+ let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (Vector Int)

43+ let message i s = ([Index i], "expected Int, encountered " <> s)

44+ res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])

45+

46+nonEmpty :: Assertion

47+nonEmpty = do

48+ let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (NL.NonEmpty Int)

49+ let message i s = ([Index i], "expected Int, encountered " <> s)

50+ res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])