186ff70 · typeable/aeson

git.iko.soy/typeable/aeson

Accumulative Parser errors

commit186ff700400a559b036c3bea613bcd9f7b0187cc authorlyxia <lysxia@gmail.com> dateMon 4 Sep 2017, 14:43 (9 years ago) parent1a845c8

4 files changed+54−33

compare with master

unifiedsplit

Data/Aeson/Parser/Internal.hs+6−5 Data/Aeson/Types.hs+2 Data/Aeson/Types/Internal.hs+39−21 tests/Properties.hs+7−7

Data/Aeson/Parser/Internal.hs+6−5

@@ -42,6 +42,7 @@ import Control.Applicative ((<|>))

4242import Control.Monad (void, when)

4343import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

4444import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

45+import Data.List.NonEmpty (NonEmpty((:|)))

4546import Data.Scientific (Scientific)

4647import Data.Text (Text)

4748import Data.Vector as Vector (Vector, empty, fromListN, reverse)

@@ -274,17 +275,17 @@ eitherDecodeWith :: Parser Value -> (Value -> IResult a) -> L.ByteString

274275eitherDecodeWith p to s =

275276 case L.parse p s of

276277 L.Done _ v -> case to v of

277− ISuccess a -> Right a

278− IError path msg -> Left (path, msg)

278+ ISuccess a -> Right a

279+ IError (e :| _) -> Left e

279280 L.Fail _ _ msg -> Left ([], msg)

280281{-# INLINE eitherDecodeWith #-}

281282

282283eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

283284 -> Either (JSONPath, String) a

284285eitherDecodeStrictWith p to s =

285− case either (IError []) to (A.parseOnly p s) of

286− ISuccess a -> Right a

287− IError path msg -> Left (path, msg)

286+ case either (\e -> IError (([], e) :| [])) to (A.parseOnly p s) of

287+ ISuccess a -> Right a

288+ IError (e :| _) -> Left e

288289{-# INLINE eitherDecodeStrictWith #-}

289290

290291-- $lazy

Data/Aeson/Types.hs+2

@@ -35,9 +35,11 @@ module Data.Aeson.Types

3535 , parseMaybe

3636 , ToJSON(..)

3737 , KeyValue(..)

38+ , liftP2

3839 , modifyFailure

3940 , parserThrowError

4041 , parserCatchError

42+ , parserCatchErrors

4143

4244 -- ** Keys for maps

4345 , ToJSONKey(..)

Data/Aeson/Types/Internal.hs+39−21

@@ -43,9 +43,11 @@ module Data.Aeson.Types.Internal

4343 , parse

4444 , parseEither

4545 , parseMaybe

46+ , liftP2

4647 , modifyFailure

4748 , parserThrowError

4849 , parserCatchError

50+ , parserCatchErrors

4951 , formatError

5052 , (<?>)

5153 -- * Constructors and accessors

@@ -87,6 +89,7 @@ import Data.Foldable (foldl')

8789import Data.HashMap.Strict (HashMap)

8890import Data.Hashable (Hashable(..))

8991import Data.List (intercalate)

92+import Data.List.NonEmpty (NonEmpty((:|)))

9093import Data.Scientific (Scientific)

9194import Data.Semigroup (Semigroup((<>)))

9295import Data.String (IsString(..))

@@ -98,6 +101,7 @@ import Data.Vector (Vector)

98101import GHC.Generics (Generic)

99102import qualified Control.Monad.Fail as Fail

100103import qualified Data.HashMap.Strict as H

104+import qualified Data.List.NonEmpty as NonEmpty

101105import qualified Data.Scientific as S

102106import qualified Data.Vector as V

103107import qualified Language.Haskell.TH.Syntax as TH

@@ -118,7 +122,7 @@ data JSONPathElement = Key Text

118122type JSONPath = [JSONPathElement]

119123

120124-- | The internal result of running a 'Parser'.

121−data IResult a = IError JSONPath String

125+data IResult a = IError (NonEmpty (JSONPath, String))

122126 | ISuccess a

123127 deriving (Eq, Show, Typeable)

124128

@@ -133,15 +137,15 @@ instance NFData JSONPathElement where

133137

134138instance (NFData a) => NFData (IResult a) where

135139 rnf (ISuccess a) = rnf a

136− rnf (IError path err) = rnf path `seq` rnf err

140+ rnf (IError err) = rnf err

137141

138142instance (NFData a) => NFData (Result a) where

139143 rnf (Success a) = rnf a

140144 rnf (Error err) = rnf err

141145

142146instance Functor IResult where

143− fmap f (ISuccess a) = ISuccess (f a)

144− fmap _ (IError path err) = IError path err

147+ fmap f (ISuccess a) = ISuccess (f a)

148+ fmap _ (IError err) = IError err

145149 {-# INLINE fmap #-}

146150

147151instance Functor Result where

@@ -153,15 +157,15 @@ instance Monad IResult where

153157 return = pure

154158 {-# INLINE return #-}

155159

156− ISuccess a >>= k = k a

157− IError path err >>= _ = IError path err

160+ ISuccess a >>= k = k a

161+ IError err >>= _ = IError err

158162 {-# INLINE (>>=) #-}

159163

160164 fail = Fail.fail

161165 {-# INLINE fail #-}

162166

163167instance Fail.MonadFail IResult where

164− fail err = IError [] err

168+ fail err = IError (([], err) :| [])

165169 {-# INLINE fail #-}

166170

167171instance Monad Result where

@@ -238,11 +242,11 @@ instance Monoid (Result a) where

238242 {-# INLINE mappend #-}

239243

240244instance Foldable IResult where

241− foldMap _ (IError _ _) = mempty

245+ foldMap _ (IError _) = mempty

242246 foldMap f (ISuccess y) = f y

243247 {-# INLINE foldMap #-}

244248

245− foldr _ z (IError _ _) = z

249+ foldr _ z (IError _) = z

246250 foldr f z (ISuccess y) = f y z

247251 {-# INLINE foldr #-}

248252

@@ -256,8 +260,8 @@ instance Foldable Result where

256260 {-# INLINE foldr #-}

257261

258262instance Traversable IResult where

259− traverse _ (IError path err) = pure (IError path err)

260− traverse f (ISuccess a) = ISuccess <$> f a

263+ traverse _ (IError err) = pure (IError err)

264+ traverse f (ISuccess a) = ISuccess <$> f a

261265 {-# INLINE traverse #-}

262266

263267instance Traversable Result where

@@ -266,7 +270,7 @@ instance Traversable Result where

266270 {-# INLINE traverse #-}

267271

268272-- | Failure continuation.

269−type Failure f r = JSONPath -> String -> f r

273+type Failure f r = NonEmpty (JSONPath, String) -> f r

270274-- | Success continuation.

271275type Success a f r = a -> f r

272276

@@ -289,7 +293,7 @@ instance Monad Parser where

289293 {-# INLINE fail #-}

290294

291295instance Fail.MonadFail Parser where

292− fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

296+ fail msg = Parser $ \path kf _ks -> kf ((reverse path, msg) :| [])

293297 {-# INLINE fail #-}

294298

295299instance Functor Parser where

@@ -309,10 +313,11 @@ instance Alternative Parser where

309313 (<|>) = mplus

310314 {-# INLINE (<|>) #-}

311315

316+{- TODO accumulate errors -}

312317instance MonadPlus Parser where

313318 mzero = fail "mzero"

314319 {-# INLINE mzero #-}

315− mplus a b = Parser $ \path kf ks -> let kf' _ _ = runParser b path kf ks

320+ mplus a b = Parser $ \path kf ks -> let kf' _ = runParser b path kf ks

316321 in runParser a path kf' ks

317322 {-# INLINE mplus #-}

318323

@@ -333,6 +338,14 @@ apP d e = do

333338 return (b a)

334339{-# INLINE apP #-}

335340

341+-- | A variant of 'liftA2' that lazily accumulates errors from both subparsers.

342+liftP2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c

343+liftP2 f pa pb = Parser $ \path kf ks ->

344+ runParser pa path

345+ (\(e :| es) -> kf (e :| es ++ runParser pb path NonEmpty.toList (const [])))

346+ (\a -> runParser pb path kf (\b -> ks (f a b)))

347+{-# INLINE liftP2 #-}

348+

336349-- | A JSON \"object\" (key\/value map).

337350type Object = HashMap Text Value

338351

@@ -423,7 +436,7 @@ emptyObject = Object H.empty

423436

424437-- | Run a 'Parser'.

425438parse :: (a -> Parser b) -> a -> Result b

426−parse m v = runParser (m v) [] (const Error) Success

439+parse m v = runParser (m v) [] (Error . snd . NonEmpty.head) Success

427440{-# INLINE parse #-}

428441

429442-- | Run a 'Parser'.

@@ -433,14 +446,14 @@ iparse m v = runParser (m v) [] IError ISuccess

433446

434447-- | Run a 'Parser' with a 'Maybe' result type.

435448parseMaybe :: (a -> Parser b) -> a -> Maybe b

436−parseMaybe m v = runParser (m v) [] (\_ _ -> Nothing) Just

449+parseMaybe m v = runParser (m v) [] (const Nothing) Just

437450{-# INLINE parseMaybe #-}

438451

439452-- | Run a 'Parser' with an 'Either' result type. If the parse fails,

440453-- the 'Left' payload will contain an error message.

441454parseEither :: (a -> Parser b) -> a -> Either String b

442455parseEither m v = runParser (m v) [] onError Right

443− where onError path msg = Left (formatError path msg)

456+ where onError ((path, err) :| _) = Left (formatError path err)

444457{-# INLINE parseEither #-}

445458

446459-- | Annotate an error message with a

@@ -510,21 +523,26 @@ p <?> pathElem = Parser $ \path kf ks -> runParser p (pathElem:path) kf ks

510523-- Since 0.6.2.0

511524modifyFailure :: (String -> String) -> Parser a -> Parser a

512525modifyFailure f (Parser p) = Parser $ \path kf ks ->

513− p path (\p' m -> kf p' (f m)) ks

526+ p path (\m -> kf ((fmap . fmap) f m)) ks

514527

515528-- | Throw a parser error with an additional path.

516529--

517530-- @since 1.2.1.0

518531parserThrowError :: JSONPath -> String -> Parser a

519532parserThrowError path' msg = Parser $ \path kf _ks ->

520− kf (reverse path ++ path') msg

533+ kf ((reverse path ++ path', msg) :| [])

521534

522535-- | A handler function to handle previous errors and return to normal execution.

523536--

524537-- @since 1.2.1.0

525538parserCatchError :: 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

539+parserCatchError p handler = parserCatchErrors p (\((e, msg) :| _) -> handler e msg)

540+

541+-- | A handler function to handle multiple previous errors and return to normal

542+-- execution.

543+parserCatchErrors :: Parser a -> (NonEmpty (JSONPath, String) -> Parser a) -> Parser a

544+parserCatchErrors (Parser p) handler = Parser $ \path kf ks ->

545+ p path (\es -> runParser (handler es) path kf ks) ks

528546

529547--------------------------------------------------------------------------------

530548-- Generic and TH encoding configuration

tests/Properties.hs+7−7

@@ -21,7 +21,7 @@ import Data.Functor.Compose (Compose (..))

2121import Data.HashMap.Strict (HashMap)

2222import Data.Hashable (Hashable)

2323import Data.Int (Int8)

24−import Data.List.NonEmpty (NonEmpty)

24+import Data.List.NonEmpty (NonEmpty((:|)))

2525import Data.Map (Map)

2626import Data.Proxy (Proxy)

2727import Data.Ratio (Ratio)

@@ -59,8 +59,8 @@ toParseJSON :: (Eq a, Show a) =>

5959 (Value -> Parser a) -> (a -> Value) -> a -> Property

6060toParseJSON parsejson tojson x =

6161 case iparse parsejson . tojson $ x of

62− IError path msg -> failure "parse" (formatError path msg) x

63− ISuccess x' -> x === x'

62+ IError ((path, msg) :| _) -> failure "parse" (formatError path msg) x

63+ ISuccess x' -> x === x'

6464

6565toParseJSON1

6666 :: (Eq (f Int), Show (f Int))

@@ -78,15 +78,15 @@ roundTripEnc :: (FromJSON a, ToJSON a, Show a) =>

7878roundTripEnc eq _ i =

7979 case fmap ifromJSON . L.parse value . encode $ i of

8080 L.Done _ (ISuccess v) -> v `eq` i

81− L.Done _ (IError path err) -> failure "fromJSON" (formatError path err) i

81+ L.Done _ (IError ((path, err) :| _)) -> failure "fromJSON" (formatError path err) i

8282 L.Fail _ _ err -> failure "parse" err i

8383

8484roundTripNoEnc :: (FromJSON a, ToJSON a, Show a) =>

8585 (a -> a -> Property) -> a -> a -> Property

8686roundTripNoEnc eq _ i =

8787 case ifromJSON . toJSON $ i of

88− (ISuccess v) -> v `eq` i

89− (IError path err) -> failure "fromJSON" (formatError path err) i

88+ ISuccess v -> v `eq` i

89+ IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) i

9090

9191roundTripEq :: (Eq a, FromJSON a, ToJSON a, Show a) => a -> a -> Property

9292roundTripEq x y = roundTripEnc (===) x y .&&. roundTripNoEnc (===) x y

@@ -104,7 +104,7 @@ x ==~ y =

104104

105105toFromJSON :: (Arbitrary a, Eq a, FromJSON a, ToJSON a, Show a) => a -> Property

106106toFromJSON x = case ifromJSON (toJSON x) of

107− IError path err -> failure "fromJSON" (formatError path err) x

107+ IError ((path, err) :| _) -> failure "fromJSON" (formatError path err) x

108108 ISuccess x' -> x === x'

109109

110110modifyFailureProp :: String -> String -> Bool