[acc-errors] Accumulate errors for Seq and Vector parsers

Data/Aeson/AccParser.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.AccParser
+  (
+    AccParser (AccParser, getParser)
+  , accSequence
+  , accTraverse
+  , (<*>+)
+  ) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Data.Aeson.Types.Internal (Parser (..), runParser)
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
+
+newtype AccParser a = AccParser { getParser :: Parser a }
+    deriving Functor
+
+instance Applicative AccParser where
+    pure = AccParser . pure
+    f <*> a = AccParser (getParser f <*>+ getParser a)
+
+-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
+-- from both subparsers.
+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
+liftP2 f pa pb = Parser $ \path kf ks ->
+  runParser pa path
+    (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
+    (\a -> runParser pb path kf (\b -> ks (f a b)))
+{-# INLINE liftP2 #-}
+
+accSequence :: Traversable t => t (Parser a) -> Parser (t a)
+accSequence = accTraverse id
+
+accTraverse :: Traversable t => (a -> Parser b) -> t a -> Parser (t b)
+accTraverse f s = getParser $ traverse' (AccParser . f) s
+
+-- Making sure we are using Applicative AccParser
+traverse' :: Traversable t => (a -> AccParser b) -> t a -> AccParser (t b)
+traverse' = traverse
+
+infixl 4 <*>+
+
+-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
+(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
+(<*>+) = liftP2 id
+{-# INLINE (<*>+) #-}

Data/Aeson/Types.hs

@@ -35,8 +35,6 @@ module Data.Aeson.Types
     , parseMaybe
     , ToJSON(..)
     , KeyValue(..)
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError

Data/Aeson/Types/FromJSON.hs

@@ -86,6 +86,7 @@ import Data.Aeson.Internal.Functions (mapKey)
 import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
+import Data.Aeson.AccParser
 import Data.Attoparsec.Number (Number(..))
 import Data.Bits (unsafeShiftR)
 import Data.Fixed (Fixed, HasResolution)
@@ -164,8 +165,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 +607,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) = getParser $ V.toList <$> traverse (AccParser . f) xs
 listParser _ v          = typeMismatch "[a]" v
 {-# INLINE listParser #-}
 
@@ -1413,7 +1414,7 @@ parseVersionText = go . readP_to_S parseVersion . unpack
 
 instance FromJSON1 NonEmpty where
     liftParseJSON p _ = withArray "NonEmpty a" $
-        (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
+        (>>= ne) . accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList
       where
         ne []     = fail "Expected a NonEmpty but got an empty list"
         ne (x:xs) = pure (x :| xs)
@@ -1438,7 +1439,7 @@ instance FromJSON Scientific where
 instance FromJSON1 DList.DList where
     liftParseJSON p _ = withArray "DList a" $
       fmap DList.fromList .
-      Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList
+      accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (DList.DList a) where
@@ -1529,7 +1530,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
+      accSequence . zipWith (parseIndexedJSON p) [0..] . V.toList
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Seq.Seq a) where
@@ -1607,7 +1608,7 @@ instance FromJSONKey UUID.UUID where
 
 instance FromJSON1 Vector where
     liftParseJSON p _ = withArray "Vector a" $
-        V.mapM (uncurry $ parseIndexedJSON p) . V.indexed
+        accTraverse (uncurry $ parseIndexedJSON p) . V.indexed
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where

Data/Aeson/Types/Internal.hs

@@ -34,7 +34,8 @@ module Data.Aeson.Types.Internal
     , emptyObject
 
     -- * Type conversion
-    , Parser
+    , Parser (Parser)
+    , runParser
     , Result(..)
     , IResult(..)
     , JSONPathElement(..)
@@ -43,8 +44,6 @@ module Data.Aeson.Types.Internal
     , parse
     , parseEither
     , parseMaybe
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
@@ -340,22 +339,6 @@ apP d e = do
   return (b a)
 {-# INLINE apP #-}
 
--- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
--- from both subparsers.
-liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
-liftP2 f pa pb = Parser $ \path kf ks ->
-  runParser pa path
-    (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
-    (\a -> runParser pb path kf (\b -> ks (f a b)))
-{-# INLINE liftP2 #-}
-
-infixl 4 <*>+
-
--- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
-(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
-(<*>+) = liftP2 id
-{-# INLINE (<*>+) #-}
-
 -- | A JSON \"object\" (key\/value map).
 type Object = HashMap Text Value
 

aeson.cabal

@@ -84,6 +84,7 @@ library
 
   exposed-modules:
     Data.Aeson
+    Data.Aeson.AccParser
     Data.Aeson.Encoding
     Data.Aeson.Parser
     Data.Aeson.Text
@@ -196,6 +197,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,58 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+module UnitTests.AccErrors (tests) where
+
+import Prelude ()
+import Prelude.Compat hiding (seq)
+
+import Data.Aeson
+import Data.DList (DList)
+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
+    , testCase "NonEmpty" nonEmpty
+    , testCase "DList" dlist
+    ]
+
+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"])
+
+nonEmpty :: Assertion
+nonEmpty = do
+    let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (NL.NonEmpty Int)
+    let message i s = ([Index i], "expected Int, encountered " <> s)
+    res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])
+
+dlist :: Assertion
+dlist = do
+    let res = decoder "[true, null]" :: Either (NonEmpty (JSONPath, String)) (DList Int)
+    let message i s = ([Index i], "expected Int, encountered " <> s)
+    res @=? Left (NL.fromList [message 0 "Boolean", message 1 "Null"])