@@ -34,7 +34,8 @@ module Data.Aeson.Types.Internal
3434 , emptyObject
3535
3636 -- * Type conversion
37− , Parser
37+ , Parser (Parser)
38+ , runParser
3839 , Result(..)
3940 , IResult(..)
4041 , JSONPathElement(..)
@@ -46,7 +47,9 @@ module Data.Aeson.Types.Internal
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
@@ -423,7 +429,7 @@ emptyObject = Object H.empty
423429
424430-- | Run a 'Parser'.
425431parse :: (a -> Parser b) -> a -> Result b
426−parse m v = runParser (m v) [] (const Error) Success
432+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success
427433{-# INLINE parse #-}
428434
429435-- | Run a 'Parser'.
@@ -433,14 +439,14 @@ iparse m v = runParser (m v) [] IError ISuccess
433439
434440-- | Run a 'Parser' with a 'Maybe' result type.
435441parseMaybe :: (a -> Parser b) -> a -> Maybe b
436−parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just
442+parseMaybe m v = runParser (m v) [] (const Nothing) Just
437443{-# INLINE parseMaybe #-}
438444
439445-- | Run a 'Parser' with an 'Either' result type. If the parse fails,
440446-- the 'Left' payload will contain an error message.
441447parseEither :: (a -> Parser b) -> a -> Either String b
442448parseEither m v = runParser (m v) [] onError Right
443− where onError path msg = Left (formatError path msg)
449+ where onError ((path, err) :| _) = Left (formatError path err)
444450{-# INLINE parseEither #-}
445451
446452-- | Annotate an error message with a
@@ -471,6 +477,10 @@ formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
471477 escapeChar '\\' = "\\\\"
472478 escapeChar c = [c]
473479
480+-- | Annotate a list of error messages.
481+formatErrors :: Functor f => f (JSONPath, String) -> f String
482+formatErrors = fmap (uncurry formatError)
483+
474484-- | A key\/value pair for an 'Object'.
475485type Pair = (Text, Value)
476486
@@ -510,21 +520,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks
510520-- Since 0.6.2.0
511521modifyFailure :: (String -> String) -> Parser a -> Parser a
512522modifyFailure f (Parser p) = Parser $ \path kf ks ->
513− p path (\p' m -> kf p' (f m)) ks
523+ p path (\m -> kf ((fmap . fmap) f m)) ks
514524
515525-- | Throw a parser error with an additional path.
516526--
517527-- @since 1.2.1.0
518528parserThrowError :: JSONPath -> String -> Parser a
519529parserThrowError path' msg = Parser $ \path kf _ks ->
520− kf (reverse path ++ path') msg
530+ kf ((reverse path ++ path', msg) :| [])
521531
522532-- | A handler function to handle previous errors and return to normal execution.
523533--
524534-- @since 1.2.1.0
525535parserCatchError :: 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
536+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)
537+
538+-- | A handler function to handle multiple previous errors and return to normal
539+-- execution.
540+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a
541+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->
542+ p path (\es -> runParser (handler es) path kf ks) ks
528543
529544--------------------------------------------------------------------------------
530545-- Generic and TH encoding configuration