@@ -43,10 +43,14 @@ module Data.Aeson.Types.Internal
4343 , parse
4444 , parseEither
4545 , parseMaybe
46+ , liftP2
47+ , (<*>+)
4648 , modifyFailure
4749 , parserThrowError
4850 , parserCatchError
51+ , parserCatchErrors
4952 , formatError
53+ , formatErrors
5054 , (<?>)
5155 -- * Constructors and accessors
5256 , object
@@ -87,6 +91,7 @@ import Data.Foldable (foldl')
8791import Data.HashMap.Strict (HashMap)
8892import Data.Hashable (Hashable(..))
8993import Data.List (intercalate)
94+import Data.List.NonEmpty (NonEmpty((:|)))
9095import Data.Scientific (Scientific)
9196import Data.Semigroup (Semigroup((<>)))
9297import Data.String (IsString(..))
@@ -98,6 +103,7 @@ import Data.Vector (Vector)
98103import GHC.Generics (Generic)
99104import qualified Control.Monad.Fail as Fail
100105import qualified Data.HashMap.Strict as H
106+import qualified Data.List.NonEmpty as NonEmpty
101107import qualified Data.Scientific as S
102108import qualified Data.Vector as V
103109import qualified Language.Haskell.TH.Syntax as TH
@@ -118,7 +124,7 @@ data JSONPathElement = Key Text
118124type JSONPath = [JSONPathElement]
119125
120126-- | The internal result of running a 'Parser'.
121−data IResult a = IError JSONPath String
127+data IResult a = IError (NonEmpty (JSONPath, String))
122128 | ISuccess a
123129 deriving (Eq, Show, Typeable)
124130
@@ -133,15 +139,15 @@ instance NFData JSONPathElement where
133139
134140instance (NFData a) => NFData (IResult a) where
135141 rnf (ISuccess a) = rnf a
136− rnf (IError path err) = rnf path `seq` rnf err
142+ rnf (IError err) = rnf err
137143
138144instance (NFData a) => NFData (Result a) where
139145 rnf (Success a) = rnf a
140146 rnf (Error err) = rnf err
141147
142148instance Functor IResult where
143− fmap f (ISuccess a) = ISuccess (f a)
144− fmap _ (IError path err) = IError path err
149+ fmap f (ISuccess a) = ISuccess (f a)
150+ fmap _ (IError err) = IError err
145151 {-# INLINE fmap #-}
146152
147153instance Functor Result where
@@ -153,15 +159,15 @@ instance Monad IResult where
153159 return = pure
154160 {-# INLINE return #-}
155161
156− ISuccess a >>= k = k a
157− IError path err >>= _ = IError path err
162+ ISuccess a >>= k = k a
163+ IError err >>= _ = IError err
158164 {-# INLINE (>>=) #-}
159165
160166 fail = Fail.fail
161167 {-# INLINE fail #-}
162168
163169instance Fail.MonadFail IResult where
164− fail err = IError [] err
170+ fail err = IError (([], err) :| [])
165171 {-# INLINE fail #-}
166172
167173instance Monad Result where
@@ -238,11 +244,11 @@ instance Monoid (Result a) where
238244 {-# INLINE mappend #-}
239245
240246instance Foldable IResult where
241− foldMap _ (IError _ _) = mempty
247+ foldMap _ (IError _) = mempty
242248 foldMap f (ISuccess y) = f y
243249 {-# INLINE foldMap #-}
244250
245− foldr _ z (IError _ _) = z
251+ foldr _ z (IError _) = z
246252 foldr f z (ISuccess y) = f y z
247253 {-# INLINE foldr #-}
248254
@@ -256,8 +262,8 @@ instance Foldable Result where
256262 {-# INLINE foldr #-}
257263
258264instance Traversable IResult where
259− traverse _ (IError path err) = pure (IError path err)
260− traverse f (ISuccess a) = ISuccess <$> f a
265+ traverse _ (IError err) = pure (IError err)
266+ traverse f (ISuccess a) = ISuccess <$> f a
261267 {-# INLINE traverse #-}
262268
263269instance Traversable Result where
@@ -266,7 +272,7 @@ instance Traversable Result where
266272 {-# INLINE traverse #-}
267273
268274-- | Failure continuation.
269−type Failure f r = JSONPath -> String -> f r
275+type Failure f r = NonEmpty (JSONPath, String) -> f r
270276-- | Success continuation.
271277type Success a f r = a -> f r
272278
@@ -289,7 +295,7 @@ instance Monad Parser where
289295 {-# INLINE fail #-}
290296
291297instance Fail.MonadFail Parser where
292− fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
298+ fail msg = Parser $ \path kf _ks -> kf ((reverse path, msg) :| [])
293299 {-# INLINE fail #-}
294300
295301instance Functor Parser where
@@ -309,10 +315,11 @@ instance Alternative Parser where
309315 (<|>) = mplus
310316 {-# INLINE (<|>) #-}
311317
318+{- TODO accumulate errors -}
312319instance MonadPlus Parser where
313320 mzero = fail "mzero"
314321 {-# INLINE mzero #-}
315− mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
322+ mplus a b = Parser $ \path kf ks -> let kf' _ = runParser b path kf ks
316323 in runParser a path kf' ks
317324 {-# INLINE mplus #-}
318325
@@ -333,6 +340,22 @@ apP d e = do
333340 return (b a)
334341{-# INLINE apP #-}
335342
343+-- | A variant of 'Control.Applicative.liftA2' that lazily accumulates errors
344+-- from both subparsers.
345+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
346+liftP2 f pa pb = Parser $ \path kf ks ->
347+ runParser pa path
348+ (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
349+ (\a -> runParser pb path kf (\b -> ks (f a b)))
350+{-# INLINE liftP2 #-}
351+
352+infixl 4 <*>+
353+
354+-- | A variant of ('<*>') that lazily accumulates errors from both subparsers.
355+(<*>+) :: Parser (a -> b) -> Parser a -> Parser b
356+(<*>+) = liftP2 id
357+{-# INLINE (<*>+) #-}
358+
336359-- | A JSON \"object\" (key\/value map).
337360type Object = HashMap Text Value
338361
@@ -423,7 +446,7 @@ emptyObject = Object H.empty
423446
424447-- | Run a 'Parser'.
425448parse :: (a -> Parser b) -> a -> Result b
426−parse m v = runParser (m v) [] (const Error) Success
449+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success
427450{-# INLINE parse #-}
428451
429452-- | Run a 'Parser'.
@@ -433,14 +456,14 @@ iparse m v = runParser (m v) [] IError ISuccess
433456
434457-- | Run a 'Parser' with a 'Maybe' result type.
435458parseMaybe :: (a -> Parser b) -> a -> Maybe b
436−parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just
459+parseMaybe m v = runParser (m v) [] (const Nothing) Just
437460{-# INLINE parseMaybe #-}
438461
439462-- | Run a 'Parser' with an 'Either' result type. If the parse fails,
440463-- the 'Left' payload will contain an error message.
441464parseEither :: (a -> Parser b) -> a -> Either String b
442465parseEither m v = runParser (m v) [] onError Right
443− where onError path msg = Left (formatError path msg)
466+ where onError ((path, err) :| _) = Left (formatError path err)
444467{-# INLINE parseEither #-}
445468
446469-- | Annotate an error message with a
@@ -471,6 +494,10 @@ formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
471494 escapeChar '\\' = "\\\\"
472495 escapeChar c = [c]
473496
497+-- | Annotate a list of error messages.
498+formatErrors :: Functor f => f (JSONPath, String) -> f String
499+formatErrors = fmap (uncurry formatError)
500+
474501-- | A key\/value pair for an 'Object'.
475502type Pair = (Text, Value)
476503
@@ -510,21 +537,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks
510537-- Since 0.6.2.0
511538modifyFailure :: (String -> String) -> Parser a -> Parser a
512539modifyFailure f (Parser p) = Parser $ \path kf ks ->
513− p path (\p' m -> kf p' (f m)) ks
540+ p path (\m -> kf ((fmap . fmap) f m)) ks
514541
515542-- | Throw a parser error with an additional path.
516543--
517544-- @since 1.2.1.0
518545parserThrowError :: JSONPath -> String -> Parser a
519546parserThrowError path' msg = Parser $ \path kf _ks ->
520− kf (reverse path ++ path') msg
547+ kf ((reverse path ++ path', msg) :| [])
521548
522549-- | A handler function to handle previous errors and return to normal execution.
523550--
524551-- @since 1.2.1.0
525552parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a
526−parserCatchError (Parser p) handler = Parser $ \path kf ks ->
527− p path (\e msg -> runParser (handler e msg) path kf ks) ks
553+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)
554+
555+-- | A handler function to handle multiple previous errors and return to normal
556+-- execution.
557+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a
558+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->
559+ p path (\es -> runParser (handler es) path kf ks) ks
528560
529561--------------------------------------------------------------------------------
530562-- Generic and TH encoding configuration