Combinator for accumulative errors

Data/Aeson.hs

@@ -37,12 +37,16 @@ module Data.Aeson
     , decode'
     , eitherDecode
     , eitherDecode'
+    , verboseDecode
+    , verboseDecode'
     , encode
     -- ** Variants for strict bytestrings
     , decodeStrict
     , decodeStrict'
     , eitherDecodeStrict
     , eitherDecodeStrict'
+    , verboseDecodeStrict
+    , verboseDecodeStrict'
     -- * Core JSON types
     , Value(..)
     , Encoding
@@ -130,9 +134,14 @@ import Prelude.Compat
 
 import Data.Aeson.Types.FromJSON (ifromJSON)
 import Data.Aeson.Encoding (encodingToLazyByteString)
-import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')
+import Data.Aeson.Parser.Internal
+  ( decodeWith, decodeStrictWith
+  , eitherDecodeWith, eitherDecodeStrictWith
+  , verboseDecodeWith, verboseDecodeStrictWith
+  , jsonEOF, json, jsonEOF', json')
 import Data.Aeson.Types
-import Data.Aeson.Types.Internal (JSONPath, formatError)
+import Data.Aeson.Types.Internal (JSONPath, formatError, formatErrors)
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as L
 
@@ -220,6 +229,35 @@ eitherDecodeStrict' =
   eitherFormatError . eitherDecodeStrictWith jsonEOF' ifromJSON
 {-# INLINE eitherDecodeStrict' #-}
 
+eitherFormatErrors
+  :: Either (NonEmpty (JSONPath, String)) a -> Either (NonEmpty String) a
+eitherFormatErrors = either (Left . formatErrors) Right
+{-# INLINE eitherFormatErrors #-}
+
+-- | Like 'decode' but returns one or more error messages when decoding fails.
+verboseDecode :: (FromJSON a) => L.ByteString -> Either (NonEmpty String) a
+verboseDecode = eitherFormatErrors . verboseDecodeWith jsonEOF ifromJSON
+{-# INLINE verboseDecode #-}
+
+-- | Like 'decodeStrict' but returns one or more error messages when decoding
+-- fails.
+verboseDecodeStrict :: (FromJSON a) => B.ByteString -> Either (NonEmpty String) a
+verboseDecodeStrict =
+  eitherFormatErrors . verboseDecodeStrictWith jsonEOF ifromJSON
+{-# INLINE verboseDecodeStrict #-}
+
+-- | Like 'decode'' but returns one or more error messages when decoding fails.
+verboseDecode' :: (FromJSON a) => L.ByteString -> Either (NonEmpty String) a
+verboseDecode' = eitherFormatErrors . verboseDecodeWith jsonEOF' ifromJSON
+{-# INLINE verboseDecode' #-}
+
+-- | Like 'decodeStrict'' but returns one or more error messages when decoding
+-- fails.
+verboseDecodeStrict' :: (FromJSON a) => B.ByteString -> Either (NonEmpty String) a
+verboseDecodeStrict' =
+  eitherFormatErrors . verboseDecodeStrictWith jsonEOF' ifromJSON
+{-# INLINE verboseDecodeStrict' #-}
+
 -- $use
 --
 -- This section contains basic information on the different ways to

Data/Aeson/Internal.hs

@@ -18,6 +18,7 @@ module Data.Aeson.Internal
     , JSONPath
     , (<?>)
     , formatError
+    , formatErrors
     , ifromJSON
     , iparse
     ) where

Data/Aeson/Parser/Internal.hs

@@ -33,6 +33,8 @@ module Data.Aeson.Parser.Internal
     , decodeStrictWith
     , eitherDecodeWith
     , eitherDecodeStrictWith
+    , verboseDecodeWith
+    , verboseDecodeStrictWith
     ) where
 
 import Prelude ()
@@ -42,6 +44,7 @@ import Control.Applicative ((<|>))
 import Control.Monad (void, when)
 import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
 import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
+import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Scientific (Scientific)
 import Data.Text (Text)
 import Data.Vector as Vector (Vector, empty, fromListN, reverse)
@@ -274,19 +277,37 @@ eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString
 eitherDecodeWith p to s =
     case L.parse p s of
       L.Done _ v     -> case to v of
-                          ISuccess a      -> Right a
-                          IError path msg -> Left (path, msg)
+                          ISuccess a -> Right a
+                          IError (e :| _) -> Left e
       L.Fail _ _ msg -> Left ([], msg)
 {-# INLINE eitherDecodeWith #-}
 
 eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
                        -> Either (JSONPath, String) a
 eitherDecodeStrictWith p to s =
-    case either (IError []) to (A.parseOnly p s) of
-      ISuccess a      -> Right a
-      IError path msg -> Left (path, msg)
+    case either (\e -> IError (([], e) :| [])) to (A.parseOnly p s) of
+      ISuccess a -> Right a
+      IError (e :| _) -> Left e
 {-# INLINE eitherDecodeStrictWith #-}
 
+verboseDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString
+                  -> Either (NonEmpty (JSONPath, String)) a
+verboseDecodeWith p to s =
+    case L.parse p s of
+      L.Done _ v     -> case to v of
+                          ISuccess a -> Right a
+                          IError   e -> Left  e
+      L.Fail _ _ msg -> Left (([], msg) :| [])
+{-# INLINE verboseDecodeWith #-}
+
+verboseDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString
+                        -> Either (NonEmpty (JSONPath, String)) a
+verboseDecodeStrictWith p to s =
+    case either (\e -> IError (([], e) :| [])) to (A.parseOnly p s) of
+      ISuccess a -> Right a
+      IError   e -> Left  e
+{-# INLINE verboseDecodeStrictWith #-}
+
 -- $lazy
 --
 -- The 'json' and 'value' parsers decouple identification from

Data/Aeson/Types.hs

@@ -35,9 +35,12 @@ module Data.Aeson.Types
     , parseMaybe
     , ToJSON(..)
     , KeyValue(..)
+    , liftP2
+    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
+    , parserCatchErrors
 
     -- ** Keys for maps
     , ToJSONKey(..)

Data/Aeson/Types/Internal.hs

@@ -43,10 +43,14 @@ module Data.Aeson.Types.Internal
     , parse
     , parseEither
     , parseMaybe
+    , liftP2
+    , (<*>+)
     , modifyFailure
     , parserThrowError
     , parserCatchError
+    , parserCatchErrors
     , formatError
+    , formatErrors
     , (<?>)
     -- * Constructors and accessors
     , object
@@ -87,6 +91,7 @@ import Data.Foldable (foldl')
 import Data.HashMap.Strict (HashMap)
 import Data.Hashable (Hashable(..))
 import Data.List (intercalate)
+import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Scientific (Scientific)
 import Data.Semigroup (Semigroup((<>)))
 import Data.String (IsString(..))
@@ -98,6 +103,7 @@ import Data.Vector (Vector)
 import GHC.Generics (Generic)
 import qualified Control.Monad.Fail as Fail
 import qualified Data.HashMap.Strict as H
+import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Scientific as S
 import qualified Data.Vector as V
 import qualified Language.Haskell.TH.Syntax as TH
@@ -118,7 +124,7 @@ data JSONPathElement = Key Text
 type JSONPath = [JSONPathElement]
 
 -- | The internal result of running a 'Parser'.
-data IResult a = IError JSONPath String
+data IResult a = IError (NonEmpty (JSONPath, String))
                | ISuccess a
                deriving (Eq, Show, Typeable)
 
@@ -133,15 +139,15 @@ instance NFData JSONPathElement where
 
 instance (NFData a) => NFData (IResult a) where
     rnf (ISuccess a)      = rnf a
-    rnf (IError path err) = rnf path `seq` rnf err
+    rnf (IError err) = rnf err
 
 instance (NFData a) => NFData (Result a) where
     rnf (Success a) = rnf a
     rnf (Error err) = rnf err
 
 instance Functor IResult where
-    fmap f (ISuccess a)      = ISuccess (f a)
-    fmap _ (IError path err) = IError path err
+    fmap f (ISuccess a) = ISuccess (f a)
+    fmap _ (IError err) = IError err
     {-# INLINE fmap #-}
 
 instance Functor Result where
@@ -153,15 +159,15 @@ instance Monad IResult where
     return = pure
     {-# INLINE return #-}
 
-    ISuccess a      >>= k = k a
-    IError path err >>= _ = IError path err
+    ISuccess a >>= k = k a
+    IError err >>= _ = IError err
     {-# INLINE (>>=) #-}
 
     fail = Fail.fail
     {-# INLINE fail #-}
 
 instance Fail.MonadFail IResult where
-    fail err = IError [] err
+    fail err = IError (([], err) :| [])
     {-# INLINE fail #-}
 
 instance Monad Result where
@@ -238,11 +244,11 @@ instance Monoid (Result a) where
     {-# INLINE mappend #-}
 
 instance Foldable IResult where
-    foldMap _ (IError _ _) = mempty
+    foldMap _ (IError _)   = mempty
     foldMap f (ISuccess y) = f y
     {-# INLINE foldMap #-}
 
-    foldr _ z (IError _ _) = z
+    foldr _ z (IError _)   = z
     foldr f z (ISuccess y) = f y z
     {-# INLINE foldr #-}
 
@@ -256,8 +262,8 @@ instance Foldable Result where
     {-# INLINE foldr #-}
 
 instance Traversable IResult where
-    traverse _ (IError path err) = pure (IError path err)
-    traverse f (ISuccess a)      = ISuccess <$> f a
+    traverse _ (IError err) = pure (IError err)
+    traverse f (ISuccess a) = ISuccess <$> f a
     {-# INLINE traverse #-}
 
 instance Traversable Result where
@@ -266,7 +272,7 @@ instance Traversable Result where
     {-# INLINE traverse #-}
 
 -- | Failure continuation.
-type Failure f r   = JSONPath -> String -> f r
+type Failure f r   = NonEmpty (JSONPath, String) -> f r
 -- | Success continuation.
 type Success a f r = a -> f r
 
@@ -289,7 +295,7 @@ instance Monad Parser where
     {-# INLINE fail #-}
 
 instance Fail.MonadFail Parser where
-    fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
+    fail msg = Parser $ \path kf _ks -> kf ((reverse path, msg) :| [])
     {-# INLINE fail #-}
 
 instance Functor Parser where
@@ -309,10 +315,11 @@ instance Alternative Parser where
     (<|>) = mplus
     {-# INLINE (<|>) #-}
 
+{- TODO accumulate errors -}
 instance MonadPlus Parser where
     mzero = fail "mzero"
     {-# INLINE mzero #-}
-    mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks
+    mplus a b = Parser $ \path kf ks -> let kf' _ = runParser b path kf ks
                                          in runParser a path kf' ks
     {-# INLINE mplus #-}
 
@@ -333,6 +340,22 @@ 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
 
@@ -423,7 +446,7 @@ emptyObject = Object H.empty
 
 -- | Run a 'Parser'.
 parse :: (a -> Parser b) -> a -> Result b
-parse m v = runParser (m v) [] (const Error) Success
+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success
 {-# INLINE parse #-}
 
 -- | Run a 'Parser'.
@@ -433,14 +456,14 @@ iparse m v = runParser (m v) [] IError ISuccess
 
 -- | Run a 'Parser' with a 'Maybe' result type.
 parseMaybe :: (a -> Parser b) -> a -> Maybe b
-parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just
+parseMaybe m v = runParser (m v) [] (const Nothing) Just
 {-# INLINE parseMaybe #-}
 
 -- | Run a 'Parser' with an 'Either' result type.  If the parse fails,
 -- the 'Left' payload will contain an error message.
 parseEither :: (a -> Parser b) -> a -> Either String b
 parseEither m v = runParser (m v) [] onError Right
-  where onError path msg = Left (formatError path msg)
+  where onError ((path, err) :| _) = Left (formatError path err)
 {-# INLINE parseEither #-}
 
 -- | Annotate an error message with a
@@ -471,6 +494,10 @@ formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg
     escapeChar '\\' = "\\\\"
     escapeChar c    = [c]
 
+-- | Annotate a list of error messages.
+formatErrors :: Functor f => f (JSONPath, String) -> f String
+formatErrors = fmap (uncurry formatError)
+
 -- | A key\/value pair for an 'Object'.
 type Pair = (Text, Value)
 
@@ -510,21 +537,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks
 -- Since 0.6.2.0
 modifyFailure :: (String -> String) -> Parser a -> Parser a
 modifyFailure f (Parser p) = Parser $ \path kf ks ->
-    p path (\p' m -> kf p' (f m)) ks
+    p path (\m -> kf ((fmap . fmap) f m)) ks
 
 -- | Throw a parser error with an additional path.
 --
 -- @since 1.2.1.0
 parserThrowError :: JSONPath -> String -> Parser a
 parserThrowError path' msg = Parser $ \path kf _ks ->
-    kf (reverse path ++ path') msg
+    kf ((reverse path ++ path', msg) :| [])
 
 -- | A handler function to handle previous errors and return to normal execution.
 --
 -- @since 1.2.1.0
 parserCatchError :: Parser a -> (JSONPath -> String -> Parser a) -> Parser a
-parserCatchError (Parser p) handler = Parser $ \path kf ks ->
-    p path (\e msg -> runParser (handler e msg) path kf ks) ks
+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)
+
+-- | A handler function to handle multiple previous errors and return to normal
+-- execution.
+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a
+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->
+    p path (\es -> runParser (handler es) path kf ks) ks
 
 --------------------------------------------------------------------------------
 -- Generic and TH encoding configuration