Accumulate errors for Seq and Vector parsers

Author: bergmark

Data/Aeson/Types/FromJSON.hs

@@ -164,8 +164,8 @@ parseIndexedJSONPair keyParser valParser idx value = p value <?> Index idx
     p = withArray "(k,v)" $ \ab ->
         let n = V.length ab
         in if n == 2
-             then (,) <$> parseJSONElemAtIndex keyParser 0 ab
-                      <*> parseJSONElemAtIndex valParser 1 ab
+             then (,) <$>  parseJSONElemAtIndex keyParser 0 ab
+                      <*>+ parseJSONElemAtIndex valParser 1 ab
              else fail $ "cannot unpack array of length " ++
                          show n ++ " into a pair"
 {-# INLINE parseIndexedJSONPair #-}
@@ -606,7 +606,7 @@ parseJSON2 = liftParseJSON2 parseJSON parseJSONList parseJSON parseJSONList
 
 -- | Helper function to use with 'liftParseJSON'. See 'Data.Aeson.ToJSON.listEncoding'.
 listParser :: (Value -> Parser a) -> Value -> Parser [a]
-listParser f (Array xs) = fmap V.toList (V.mapM f xs)
+listParser f (Array xs) = fmap V.toList (accumulateTraverseVector f xs)
 listParser _ v          = typeMismatch "[a]" v
 {-# INLINE listParser #-}
 
@@ -1529,7 +1529,7 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Sum f g a) where
 instance FromJSON1 Seq.Seq where
     liftParseJSON p _ = withArray "Seq a" $
       fmap Seq.fromList .
-      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
+      accumulateSequenceList . zipWith (parseIndexedJSON p) [0..] . V.toList
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -1607,7 +1607,7 @@ instance FromJSONKey UUID.UUID where
 
 instance FromJSON1 Vector where
     liftParseJSON p _ = withArray "Vector a" $
-        V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
+        accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where

Data/Aeson/Types/Internal.hs

@@ -25,8 +25,12 @@
 
 module Data.Aeson.Types.Internal
     (
+      accumulateSequenceList
+    , accumulateTraverseList
+    , accumulateTraverseVector
+
     -- * Core JSON types
-      Value(..)
+    , Value(..)
     , Array
     , emptyArray, isEmptyArray
     , Pair
@@ -349,6 +353,20 @@ liftP2 f pa pb = Parser $ \path kf ks ->
     (\a -> runParser pb path kf (\b -> ks (f a b)))
 {-# INLINE liftP2 #-}
 
+accumulateSequenceList :: [Parser a] -> Parser [a]
+accumulateSequenceList = accumulateTraverseList id
+
+accumulateTraverseList :: (a -> Parser b) -> [a] -> Parser [b]
+accumulateTraverseList f s = case s of
+  []    -> pure mempty
+  h : t -> (:) <$> (f h) <*>+ (accumulateTraverseList f t)
+
+accumulateTraverseVector :: (a -> Parser b) -> Vector a -> Parser (Vector b)
+accumulateTraverseVector f v =
+    if V.null v
+        then pure mempty
+        else V.cons <$> (f $ V.head v) <*>+ (accumulateTraverseVector f $ V.tail v)
+
 infixl 4 <*>+
 
 -- | A variant of ('<*>') that lazily accumulates errors from both subparsers.

aeson.cabal

@@ -196,6 +196,7 @@ test-suite tests
     SerializationFormatSpec
     Types
     UnitTests
+    UnitTests.AccErrors
     UnitTests.NullaryConstructors
 
   build-depends:

tests/Tests.hs

@@ -7,8 +7,15 @@ import Test.Framework (defaultMain)
 import qualified DataFamilies.Properties as DF
 import qualified Properties
 import qualified UnitTests
+import qualified UnitTests.AccErrors as AccErrors
 
 main :: IO ()
 main = do
     ioTests <- UnitTests.ioTests
-    defaultMain (DF.tests : Properties.tests : UnitTests.tests : ioTests)
+    defaultMain
+        ( AccErrors.tests
+        : DF.tests
+        : Properties.tests
+        : UnitTests.tests
+        : ioTests
+        )

tests/UnitTests/AccErrors.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+module UnitTests.AccErrors (tests) where
+
+import Prelude ()
+import Prelude.Compat hiding (seq)
+
+import Data.Aeson
+import Data.Aeson.Parser.Internal
+import Data.Aeson.Types ()
+import Data.Aeson.Internal
+import Data.List.NonEmpty (NonEmpty)
+import Data.Semigroup
+import Data.Vector (Vector)
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test)
+import qualified Data.ByteString.Lazy as L
+import qualified Data.List.NonEmpty as NL
+import qualified Data.Sequence as Seq
+
+tests :: Test
+tests = testGroup "Error accumulation" [
+      testCase "seq" seq
+    , testCase "vector" vector
+    ]
+
+decoder :: FromJSON a
+    => L.ByteString
+    -> Either (NonEmpty (JSONPath, String)) a
+decoder = verboseDecodeWith jsonEOF ifromJSON
+
+seq :: Assertion
+seq = do
+    let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (Seq.Seq Int)
+    let message i s = ([Index i], "expected Int, encountered " <> s)
+    res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])
+
+vector :: Assertion
+vector = do
+    let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (Vector Int)
+    let message i s = ([Index i], "expected Int, encountered " <> s)
+    res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])