From abdb8a3541639546a18271c4d52ede2c2909b48a Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Sun, 29 Oct 2017 18:32:27 +0100
Subject: [PATCH 1/4] Accumulate errors for Seq and Vector parsers

---
 Data/Aeson/Types/FromJSON.hs | 10 ++++-----
 Data/Aeson/Types/Internal.hs | 20 ++++++++++++++++-
 aeson.cabal                  |  1 +
 tests/Tests.hs               |  9 +++++++-
 tests/UnitTests/AccErrors.hs | 43 ++++++++++++++++++++++++++++++++++++
 5 files changed, 76 insertions(+), 7 deletions(-)
 create mode 100644 tests/UnitTests/AccErrors.hs

diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs
index 802613086..9b2e49d37 100644
--- a/Data/Aeson/Types/FromJSON.hs
+++ b/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
diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs
index 39e109124..54bdca8b8 100644
--- a/Data/Aeson/Types/Internal.hs
+++ b/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.
diff --git a/aeson.cabal b/aeson.cabal
index 5af060dee..5b7f93e4d 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -196,6 +196,7 @@ test-suite tests
     SerializationFormatSpec
     Types
     UnitTests
+    UnitTests.AccErrors
     UnitTests.NullaryConstructors
 
   build-depends:
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 63826a1bc..98c13597a 100644
--- a/tests/Tests.hs
+++ b/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
+        )
diff --git a/tests/UnitTests/AccErrors.hs b/tests/UnitTests/AccErrors.hs
new file mode 100644
index 000000000..eb4e281b8
--- /dev/null
+++ b/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"])

From 9eef7e7425a1367389f4feaa1d7ad8e7ead4674c Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Sat, 23 Dec 2017 15:57:50 +0100
Subject: [PATCH 2/4] AccParser newtype with accumulating Applicative instance

---
 Data/Aeson/AccParser.hs      | 46 ++++++++++++++++++++++++++++++++++++
 Data/Aeson/Types.hs          |  2 --
 Data/Aeson/Types/FromJSON.hs |  7 +++---
 Data/Aeson/Types/Internal.hs | 41 +++-----------------------------
 aeson.cabal                  |  1 +
 5 files changed, 54 insertions(+), 43 deletions(-)
 create mode 100644 Data/Aeson/AccParser.hs

diff --git a/Data/Aeson/AccParser.hs b/Data/Aeson/AccParser.hs
new file mode 100644
index 000000000..cae8f9810
--- /dev/null
+++ b/Data/Aeson/AccParser.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Data.Aeson.AccParser
+  (
+    AccParser (AccParser, getParser)
+  , accSequence
+  , accTraverse
+  , (<*>+)
+  ) where
+
+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 (<*>+) #-}
diff --git a/Data/Aeson/Types.hs b/Data/Aeson/Types.hs
index 338346962..cb6689701 100644
--- a/Data/Aeson/Types.hs
+++ b/Data/Aeson/Types.hs
@@ -35,8 +35,6 @@ module Data.Aeson.Types
     , parseMaybe
     , ToJSON(..)
     , KeyValue(..)
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs
index 9b2e49d37..2dc754c96 100644
--- a/Data/Aeson/Types/FromJSON.hs
+++ b/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)
@@ -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 (accumulateTraverseVector f xs)
+listParser f (Array xs) = getParser $ V.toList <$> traverse (AccParser . f) xs
 listParser _ v          = typeMismatch "[a]" v
 {-# INLINE listParser #-}
 
@@ -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 .
-      accumulateSequenceList . 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" $
-        accumulateTraverseVector (uncurry $ parseIndexedJSON p) . V.indexed
+        accTraverse (uncurry $ parseIndexedJSON p) . V.indexed
     {-# INLINE liftParseJSON #-}
 
 instance (FromJSON a) => FromJSON (Vector a) where
diff --git a/Data/Aeson/Types/Internal.hs b/Data/Aeson/Types/Internal.hs
index 54bdca8b8..ccca1bb4b 100644
--- a/Data/Aeson/Types/Internal.hs
+++ b/Data/Aeson/Types/Internal.hs
@@ -25,12 +25,8 @@
 
 module Data.Aeson.Types.Internal
     (
-      accumulateSequenceList
-    , accumulateTraverseList
-    , accumulateTraverseVector
-
     -- * Core JSON types
-    , Value(..)
+      Value(..)
     , Array
     , emptyArray, isEmptyArray
     , Pair
@@ -38,7 +34,8 @@ module Data.Aeson.Types.Internal
     , emptyObject
 
     -- * Type conversion
-    , Parser
+    , Parser (Parser)
+    , runParser
     , Result(..)
     , IResult(..)
     , JSONPathElement(..)
@@ -47,8 +44,6 @@ module Data.Aeson.Types.Internal
     , parse
     , parseEither
     , parseMaybe
-    , liftP2
-    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
@@ -344,36 +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 #-}
-
-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.
-(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
-(<*>+) = liftP2 id
-{-# INLINE (<*>+) #-}
-
 -- | A JSON \"object\" (key\/value map).
 type Object = HashMap Text Value
 
diff --git a/aeson.cabal b/aeson.cabal
index 5b7f93e4d..9f48c043e 100644
--- a/aeson.cabal
+++ b/aeson.cabal
@@ -84,6 +84,7 @@ library
 
   exposed-modules:
     Data.Aeson
+    Data.Aeson.AccParser
     Data.Aeson.Encoding
     Data.Aeson.Parser
     Data.Aeson.Text

From 7bcf368af913fd03199293a026665d74e7ebed95 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Mon, 25 Dec 2017 18:53:46 +0100
Subject: [PATCH 3/4] Accumulate NonEmpty errors

---
 Data/Aeson/Types/FromJSON.hs |  2 +-
 tests/UnitTests/AccErrors.hs | 11 +++++++++--
 2 files changed, 10 insertions(+), 3 deletions(-)

diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs
index 2dc754c96..d2d1580e2 100644
--- a/Data/Aeson/Types/FromJSON.hs
+++ b/Data/Aeson/Types/FromJSON.hs
@@ -1414,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)
diff --git a/tests/UnitTests/AccErrors.hs b/tests/UnitTests/AccErrors.hs
index eb4e281b8..786091427 100644
--- a/tests/UnitTests/AccErrors.hs
+++ b/tests/UnitTests/AccErrors.hs
@@ -21,8 +21,9 @@ import qualified Data.Sequence as Seq
 
 tests :: Test
 tests = testGroup "Error accumulation" [
-      testCase "seq" seq
-    , testCase "vector" vector
+      testCase "Seq" seq
+    , testCase "Vector" vector
+    , testCase "NonEmpty" nonEmpty
     ]
 
 decoder :: FromJSON a
@@ -41,3 +42,9 @@ 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"])

From 584135e8e65df292c36530b79fa53f07f15cb3b4 Mon Sep 17 00:00:00 2001
From: Adam Bergmark <adam@bergmark.nl>
Date: Mon, 25 Dec 2017 18:55:28 +0100
Subject: [PATCH 4/4] Accumulate DList errors

---
 Data/Aeson/AccParser.hs      | 3 +++
 Data/Aeson/Types/FromJSON.hs | 2 +-
 tests/UnitTests/AccErrors.hs | 8 ++++++++
 3 files changed, 12 insertions(+), 1 deletion(-)

diff --git a/Data/Aeson/AccParser.hs b/Data/Aeson/AccParser.hs
index cae8f9810..9141cd93d 100644
--- a/Data/Aeson/AccParser.hs
+++ b/Data/Aeson/AccParser.hs
@@ -8,6 +8,9 @@ module Data.Aeson.AccParser
   , (<*>+)
   ) 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
diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs
index d2d1580e2..86beb7948 100644
--- a/Data/Aeson/Types/FromJSON.hs
+++ b/Data/Aeson/Types/FromJSON.hs
@@ -1439,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
diff --git a/tests/UnitTests/AccErrors.hs b/tests/UnitTests/AccErrors.hs
index 786091427..9efc6fc0f 100644
--- a/tests/UnitTests/AccErrors.hs
+++ b/tests/UnitTests/AccErrors.hs
@@ -6,6 +6,7 @@ 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
@@ -24,6 +25,7 @@ tests = testGroup "Error accumulation" [
       testCase "Seq" seq
     , testCase "Vector" vector
     , testCase "NonEmpty" nonEmpty
+    , testCase "DList" dlist
     ]
 
 decoder :: FromJSON a
@@ -48,3 +50,9 @@ 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"])