@@ -43,10 +43,13 @@ module Data.Aeson.Types.Internal
4343 , parse
4444 , parseEither
4545 , parseMaybe
46+ , liftP2
4647 , modifyFailure
4748 , parserThrowError
4849 , parserCatchError
50+ , parserCatchErrors
4951 , formatError
52+ , formatErrors
5053 , (<?>)
5154 -- * Constructors and accessors
5255 , object
@@ -87,6 +90,7 @@ import Data.Foldable (foldl')
8790import Data.HashMap.Strict (HashMap)
8891import Data.Hashable (Hashable(..))
8992import Data.List (intercalate)
93+import Data.List.NonEmpty (NonEmpty((:|)))
9094import Data.Scientific (Scientific)
9195import Data.Semigroup (Semigroup((<>)))
9296import Data.String (IsString(..))
@@ -98,6 +102,7 @@ import Data.Vector (Vector)
98102import GHC.Generics (Generic)
99103import qualified Control.Monad.Fail as Fail
100104import qualified Data.HashMap.Strict as H
105+import qualified Data.List.NonEmpty as NonEmpty
101106import qualified Data.Scientific as S
102107import qualified Data.Vector as V
103108import qualified Language.Haskell.TH.Syntax as TH
@@ -118,7 +123,7 @@ data JSONPathElement = Key Text
118123type JSONPath = [JSONPathElement]
119124
120125-- | The internal result of running a 'Parser'.
121−data IResult a = IError JSONPath String
126+data IResult a = IError (NonEmpty (JSONPath, String))
122127 | ISuccess a
123128 deriving (Eq, Show, Typeable)
124129
@@ -133,15 +138,15 @@ instance NFData JSONPathElement where
133138
134139instance (NFData a) => NFData (IResult a) where
135140 rnf (ISuccess a) = rnf a
136− rnf (IError path err) = rnf path `seq` rnf err
141+ rnf (IError err) = rnf err
137142
138143instance (NFData a) => NFData (Result a) where
139144 rnf (Success a) = rnf a
140145 rnf (Error err) = rnf err
141146
142147instance Functor IResult where
143− fmap f (ISuccess a) = ISuccess (f a)
144− fmap _ (IError path err) = IError path err
148+ fmap f (ISuccess a) = ISuccess (f a)
149+ fmap _ (IError err) = IError err
145150 {-# INLINE fmap #-}
146151
147152instance Functor Result where
@@ -153,15 +158,15 @@ instance Monad IResult where
153158 return = pure
154159 {-# INLINE return #-}
155160
156− ISuccess a >>= k = k a
157− IError path err >>= _ = IError path err
161+ ISuccess a >>= k = k a
162+ IError err >>= _ = IError err
158163 {-# INLINE (>>=) #-}
159164
160165 fail = Fail.fail
161166 {-# INLINE fail #-}
162167
163168instance Fail.MonadFail IResult where
164− fail err = IError [] err
169+ fail err = IError (([], err) :| [])
165170 {-# INLINE fail #-}
166171
167172instance Monad Result where
@@ -238,11 +243,11 @@ instance Monoid (Result a) where
238243 {-# INLINE mappend #-}
239244
240245instance Foldable IResult where
241− foldMap _ (IError _ _) = mempty
246+ foldMap _ (IError _) = mempty
242247 foldMap f (ISuccess y) = f y
243248 {-# INLINE foldMap #-}
244249
245− foldr _ z (IError _ _) = z
250+ foldr _ z (IError _) = z
246251 foldr f z (ISuccess y) = f y z
247252 {-# INLINE foldr #-}
248253
@@ -256,8 +261,8 @@ instance Foldable Result where
256261 {-# INLINE foldr #-}
257262
258263instance Traversable IResult where
259− traverse _ (IError path err) = pure (IError path err)
260− traverse f (ISuccess a) = ISuccess <$> f a
264+ traverse _ (IError err) = pure (IError err)
265+ traverse f (ISuccess a) = ISuccess <$> f a
261266 {-# INLINE traverse #-}
262267
263268instance Traversable Result where
@@ -266,7 +271,7 @@ instance Traversable Result where
266271 {-# INLINE traverse #-}
267272
268273-- | Failure continuation.
269−type Failure f r = JSONPath -> String -> f r
274+type Failure f r = NonEmpty (JSONPath, String) -> f r
270275-- | Success continuation.
271276type Success a f r = a -> f r
272277
@@ -289,7 +294,7 @@ instance Monad Parser where
289294 {-# INLINE fail #-}
290295
291296instance Fail.MonadFail Parser where
292− fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
297+ fail msg = Parser $ \path kf _ks -> kf ((reverse path, msg) :| [])
293298 {-# INLINE fail #-}
294299
295300instance Functor Parser where
@@ -309,10 +314,11 @@ instance Alternative Parser where
309314 (<|>) = mplus
310315 {-# INLINE (<|>) #-}
311316
317+{- TODO accumulate errors -}
312318instance MonadPlus Parser where
313319 mzero = fail "mzero"
314320 {-# INLINE mzero #-}
315− mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
321+ mplus a b = Parser $ \path kf ks -> let kf' _ = runParser b path kf ks
316322 in runParser a path kf' ks
317323 {-# INLINE mplus #-}
318324
@@ -333,6 +339,14 @@ apP d e = do
333339 return (b a)
334340{-# INLINE apP #-}
335341
342+-- | A variant of 'liftA2' that lazily accumulates errors from both subparsers.
343+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c
344+liftP2 f pa pb = Parser $ \path kf ks ->
345+ runParser pa path
346+ (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))
347+ (\a -> runParser pb path kf (\b -> ks (f a b)))
348+{-# INLINE liftP2 #-}
349+
336350-- | A JSON \"object\" (key\/value map).
337351type Object = HashMap Text Value
338352
@@ -423,7 +437,7 @@ emptyObject = Object H.empty
423437
424438-- | Run a 'Parser'.
425439parse :: (a -> Parser b) -> a -> Result b
426−parse m v = runParser (m v) [] (const Error) Success
440+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success
427441{-# INLINE parse #-}
428442
429443-- | Run a 'Parser'.
@@ -433,14 +447,14 @@ iparse m v = runParser (m v) [] IError ISuccess
433447
434448-- | Run a 'Parser' with a 'Maybe' result type.
435449parseMaybe :: (a -> Parser b) -> a -> Maybe b
436−parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just
450+parseMaybe m v = runParser (m v) [] (const Nothing) Just
437451{-# INLINE parseMaybe #-}
438452
439453-- | Run a 'Parser' with an 'Either' result type. If the parse fails,
440454-- the 'Left' payload will contain an error message.
441455parseEither :: (a -> Parser b) -> a -> Either String b
442456parseEither m v = runParser (m v) [] onError Right
443− where onError path msg = Left (formatError path msg)
457+ where onError ((path, err) :| _) = Left (formatError path err)
444458{-# INLINE parseEither #-}
445459
446460-- | Annotate an error message with a
@@ -471,6 +485,10 @@ formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
471485 escapeChar '\\' = "\\\\"
472486 escapeChar c = [c]
473487
488+-- | Annotate a list of error messages.
489+formatErrors :: Functor f => f (JSONPath, String) -> f String
490+formatErrors = fmap (uncurry formatError)
491+
474492-- | A key\/value pair for an 'Object'.
475493type Pair = (Text, Value)
476494
@@ -510,21 +528,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks
510528-- Since 0.6.2.0
511529modifyFailure :: (String -> String) -> Parser a -> Parser a
512530modifyFailure f (Parser p) = Parser $ \path kf ks ->
513− p path (\p' m -> kf p' (f m)) ks
531+ p path (\m -> kf ((fmap . fmap) f m)) ks
514532
515533-- | Throw a parser error with an additional path.
516534--
517535-- @since 1.2.1.0
518536parserThrowError :: JSONPath -> String -> Parser a
519537parserThrowError path' msg = Parser $ \path kf _ks ->
520− kf (reverse path ++ path') msg
538+ kf ((reverse path ++ path', msg) :| [])
521539
522540-- | A handler function to handle previous errors and return to normal execution.
523541--
524542-- @since 1.2.1.0
525543parserCatchError :: 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
544+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)
545+
546+-- | A handler function to handle multiple previous errors and return to normal
547+-- execution.
548+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a
549+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->
550+ p path (\es -> runParser (handler es) path kf ks) ks
528551
529552--------------------------------------------------------------------------------
530553-- Generic and TH encoding configuration