abdb8a3 · typeable/aeson

Data/Aeson/Types/FromJSON.hs+5−5

compare with master

unifiedsplit

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

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

165 let n = V.length ab

166 in if n == 2

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

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

168− <*> parseJSONElemAtIndex valParser 1 ab

168+ <*>+ parseJSONElemAtIndex valParser 1 ab

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

170 show n ++ " into a pair"

171{-# INLINE parseIndexedJSONPair #-}

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

606

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

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

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

609+listParser f (Array xs) = fmap V.toList (accumulateTraverseVector f xs)

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

611{-# INLINE listParser #-}

612

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

1529instance FromJSON1 Seq.Seq where

1530 liftParseJSON p _ = withArray "Seq a" $

1531 fmap Seq.fromList .

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

1532+ accumulateSequenceList . zipWith (parseIndexedJSON p) [0..] . V.toList

1533 {-# INLINE liftParseJSON #-}

1534

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

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

1607

1608instance FromJSON1 Vector where

1609 liftParseJSON p _ = withArray "Vector a" $

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

1610+ accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed

1611 {-# INLINE liftParseJSON #-}

1612

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

Data/Aeson/Types/Internal.hs+19−1

@@ -25,8 +25,12 @@

25

26module Data.Aeson.Types.Internal

27 (

28+ accumulateSequenceList

29+ , accumulateTraverseList

30+ , accumulateTraverseVector

31+

28 -- * Core JSON types

32 -- * Core JSON types

29− Value(..)

33+ , Value(..)

30 , Array

34 , Array

31 , emptyArray, isEmptyArray

35 , emptyArray, isEmptyArray

32 , Pair

36 , Pair

@@ -349,6 +353,20 @@ liftP2 f pa pb = Parser $ \path kf ks ->

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

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

350{-# INLINE liftP2 #-}

354{-# INLINE liftP2 #-}

351

355

356+accumulateSequenceList :: [Parser a] -> Parser [a]

357+accumulateSequenceList = accumulateTraverseList id

358+

359+accumulateTraverseList :: (a -> Parser b) -> [a] -> Parser [b]

360+accumulateTraverseList f s = case s of

361+ [] -> pure mempty

362+ h : t -> (:) <$> (f h) <*>+ (accumulateTraverseList f t)

363+

364+accumulateTraverseVector :: (a -> Parser b) -> Vector a -> Parser (Vector b)

365+accumulateTraverseVector f v =

366+ if V.null v

367+ then pure mempty

368+ else V.cons <$> (f $ V.head v) <*>+ (accumulateTraverseVector f $ V.tail v)

369+

352infixl 4 <*>+

370infixl 4 <*>+

353

371

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

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

aeson.cabal+1

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

196 SerializationFormatSpec

197 Types

198 UnitTests

199+ UnitTests.AccErrors

199 UnitTests.NullaryConstructors

200 UnitTests.NullaryConstructors

200

201

201 build-depends:

202 build-depends:

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

10

11

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+43

@@ -0,0 +1,43 @@

1+{-# LANGUAGE NoMonomorphismRestriction #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module UnitTests.AccErrors (tests) where

4+

5+import Prelude ()

6+import Prelude.Compat hiding (seq)

7+

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+ ]

27+

28+decoder :: FromJSON a

29+ => L.ByteString

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

31+decoder = verboseDecodeWith jsonEOF ifromJSON

32+

33+seq :: Assertion

34+seq = do

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

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

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

38+

39+vector :: Assertion

40+vector = do

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

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

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