git.iko.soy/typeable/aeson
on master help sign in
Accumulate errors for Seq and Vector parsers
commitabdb8a3541639546a18271c4d52ede2c2909b48a authorAdam Bergmark <adam@bergmark.nl> dateSun 29 Oct 2017, 18:32 (9 years ago) parent0f13c59
5 files changed+76−7
compare with master
unifiedsplit
Data/Aeson/Types/FromJSON.hs+5−5 Data/Aeson/Types/Internal.hs+19−1 aeson.cabal+1 tests/Tests.hs+8−1 tests/UnitTests/AccErrors.hs+43
Data/Aeson/Types/FromJSON.hs+5−5
@@ -164,8 +164,8 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
164164 p = withArray "(k,v)" $ \ab ->
165165 let n = V.length ab
166166 in if n == 2
167− then (,) <$> parseJSONElemAtIndex keyParser 0 ab
168− <*> parseJSONElemAtIndex valParser 1 ab
167+ then (,) <$> parseJSONElemAtIndex keyParser 0 ab
168+ <*>+ parseJSONElemAtIndex valParser 1 ab
169169 else fail $ "cannot unpack array of length " ++
170170 show n ++ " into a pair"
171171{-# INLINE parseIndexedJSONPair #-}
@@ -606,7 +606,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
606606
607607-- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
608608listParser :: (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)
610610listParser _ v = typeMismatch "[a]" v
611611{-# INLINE listParser #-}
612612
@@ -1529,7 +1529,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
15291529instance FromJSON1 Seq.Seq where
15301530 liftParseJSON p _ = withArray "Seq a" $
15311531 fmap Seq.fromList .
1532− Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
1532+ accumulateSequenceList . zipWith (parseIndexedJSON p) [0..] . V.toList
15331533 {-# INLINE liftParseJSON #-}
15341534
15351535instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -1607,7 +1607,7 @@ instance FromJSONKey UUID.UUID where
16071607
16081608instance FromJSON1 Vector where
16091609 liftParseJSON p _ = withArray "Vector a" $
1610− V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
1610+ accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed
16111611 {-# INLINE liftParseJSON #-}
16121612
16131613instance (FromJSON a) => FromJSON (Vector a) where
Data/Aeson/Types/Internal.hs+19−1
@@ -25,8 +25,12 @@
2525
2626module Data.Aeson.Types.Internal
2727 (
28+ accumulateSequenceList
29+ , accumulateTraverseList
30+ , accumulateTraverseVector
31+
2832 -- * Core JSON types
29− Value(..)
33+ , Value(..)
3034 , Array
3135 , emptyArray, isEmptyArray
3236 , Pair
@@ -349,6 +353,20 @@ liftP2 f pa pb = Parser $ \path kf ks ->
349353 (\a -> runParser pb path kf (\b -> ks (f a b)))
350354{-# INLINE liftP2 #-}
351355
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+
352370infixl 4 <*>+
353371
354372-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
aeson.cabal+1
@@ -196,6 +196,7 @@ test-suite tests
196196 SerializationFormatSpec
197197 Types
198198 UnitTests
199+ UnitTests.AccErrors
199200 UnitTests.NullaryConstructors
200201
201202 build-depends:
tests/Tests.hs+8−1
@@ -7,8 +7,15 @@ import Test.Framework (defaultMain)
77import qualified DataFamilies.Properties as DF
88import qualified Properties
99import qualified UnitTests
10+import qualified UnitTests.AccErrors as AccErrors
1011
1112main :: IO ()
1213main = do
1314 ioTests <- UnitTests.ioTests
14− defaultMain (DF.tests : Properties.tests : UnitTests.tests : ioTests)
15+ defaultMain
16+ ( AccErrors.tests
17+ : DF.tests
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"])