module Data.Aeson.BetterErrors.Internal where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Error.Class (MonadError(..))
import Data.Void
import Data.Foldable (foldMap)
import Data.Monoid
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Data.Vector ((!?))
import qualified Data.Vector as V
import Data.Scientific (Scientific)
import qualified Data.Scientific as S
import qualified Data.HashMap.Strict as HashMap
import Data.Aeson.BetterErrors.Utils
newtype Parse err a
= Parse (ReaderT ParseReader (Except (ParseError err)) a)
deriving (Functor, Applicative, Monad,
MonadReader ParseReader, MonadError (ParseError err))
runParse :: Parse err a -> A.Value -> Either (ParseError err) a
runParse (Parse p) v = runExcept (runReaderT p (ParseReader DList.empty v))
mapError :: (err -> err') -> Parse err a -> Parse err' a
mapError f p = do
v <- asks rdrValue
case runParse p v of
Right x -> pure x
Left err -> throwError (f <$> err)
(.!) :: Parse err a -> (err -> err') -> Parse err' a
(.!) = flip mapError
type Parse' = Parse Void
runParser ::
(s -> Either String A.Value) ->
Parse err a ->
s ->
Either (ParseError err) a
runParser decode p src =
case decode src of
Left err -> Left (InvalidJSON err)
Right value -> runParse p value
parse :: Parse err a -> BL.ByteString -> Either (ParseError err) a
parse = runParser A.eitherDecode
parseStrict :: Parse err a -> B.ByteString -> Either (ParseError err) a
parseStrict = runParser A.eitherDecodeStrict
parseValue :: Parse err a -> A.Value -> Either (ParseError err) a
parseValue = runParser Right
toAesonParser :: (err -> Text) -> Parse err a -> A.Value -> A.Parser a
toAesonParser showCustom p val =
case parseValue p val of
Right x -> return x
Left err -> fail (unlines (map T.unpack (displayError showCustom err)))
toAesonParser' :: Parse' a -> A.Value -> A.Parser a
toAesonParser' = toAesonParser absurd
fromAesonParser :: A.FromJSON a => Parse e a
fromAesonParser = liftParse $ \v ->
case A.fromJSON v of
A.Success x -> Right x
A.Error err -> Left (FromAeson err)
data ParseReader = ParseReader
{ rdrPath :: DList PathPiece
, rdrValue :: A.Value
}
appendPath :: PathPiece -> ParseReader -> ParseReader
appendPath p r = r { rdrPath = DList.snoc (rdrPath r) p }
setValue :: A.Value -> ParseReader -> ParseReader
setValue v r = r { rdrValue = v }
data PathPiece
= ObjectKey Text
| ArrayIndex Int
deriving (Show, Eq, Ord)
data ParseError err
= InvalidJSON String
| BadSchema [PathPiece] (ErrorSpecifics err)
deriving (Show, Eq, Functor)
type ParseError' = ParseError Void
data ErrorSpecifics err
= KeyMissing Text
| OutOfBounds Int
| WrongType JSONType A.Value
| ExpectedIntegral Double
| FromAeson String
| CustomError err
deriving (Show, Eq, Functor)
type ErrorSpecifics' = ErrorSpecifics Void
data JSONType
= TyObject
| TyArray
| TyString
| TyNumber
| TyBool
| TyNull
deriving (Show, Eq, Ord)
displayJSONType :: JSONType -> Text
displayJSONType t = case t of
TyObject -> "object"
TyArray -> "array"
TyString -> "string"
TyNumber -> "number"
TyBool -> "boolean"
TyNull -> "null"
displayError :: (err -> Text) -> ParseError err -> [Text]
displayError _ (InvalidJSON str) =
[ "The input could not be parsed as JSON", "aeson said: " <> T.pack str ]
displayError f (BadSchema [] specs) =
displaySpecifics f specs
displayError f (BadSchema path specs) =
[ "At the path: " <> displayPath path ] <> displaySpecifics f specs
displayError' :: ParseError' -> [Text]
displayError' = displayError absurd
displayPath :: [PathPiece] -> Text
displayPath = foldMap showPiece
where
showPiece (ObjectKey t) = "[" <> tshow t <> "]"
showPiece (ArrayIndex i) = "[" <> tshow i <> "]"
displaySpecifics :: (err -> Text) -> ErrorSpecifics err -> [Text]
displaySpecifics _ (KeyMissing k) =
[ "The required key " <> tshow k <> " is missing" ]
displaySpecifics _ (OutOfBounds i) =
[ "The array index " <> tshow i <> " is out of bounds" ]
displaySpecifics _ (WrongType t val) =
[ "Type mismatch:"
, "Expected a value of type " <> displayJSONType t
, "Got: " <> decodeUtf8 (B.concat (BL.toChunks (A.encode val)))
]
displaySpecifics _ (ExpectedIntegral x) =
[ "Expected an integral value, got " <> tshow x ]
displaySpecifics _ (FromAeson str) =
[ "Arising from an Aeson FromJSON instance:"
, T.pack str
]
displaySpecifics f (CustomError err) =
[ f err ]
displaySpecifics' :: ErrorSpecifics' -> [Text]
displaySpecifics' = displaySpecifics absurd
jsonTypeOf :: A.Value -> JSONType
jsonTypeOf (A.Object _) = TyObject
jsonTypeOf (A.Array _) = TyArray
jsonTypeOf (A.String _) = TyString
jsonTypeOf (A.Number _) = TyNumber
jsonTypeOf (A.Bool _) = TyBool
jsonTypeOf A.Null = TyNull
liftParse :: (A.Value -> Either (ErrorSpecifics err) a) -> Parse err a
liftParse f =
asks rdrValue
>>= either badSchema return . f
badSchema :: ErrorSpecifics err -> Parse err a
badSchema specifics = do
path <- asks rdrPath
throwError (BadSchema (DList.toList path) specifics)
as :: (A.Value -> Maybe a) -> JSONType -> Parse err a
as pat ty = liftParse $ \v ->
maybe (Left (WrongType ty v)) Right (pat v)
asText :: Parse err Text
asText = as patString TyString
asString :: Parse err String
asString = T.unpack <$> asText
asScientific :: Parse err Scientific
asScientific = as patNumber TyNumber
asIntegral :: Integral a => Parse err a
asIntegral =
S.floatingOrInteger <$> asScientific
>>= either (badSchema . ExpectedIntegral) return
asRealFloat :: RealFloat a => Parse err a
asRealFloat =
floatingOrInteger <$> asScientific
>>= either return (return . fromIntegral)
where
floatingOrInteger :: RealFloat b => Scientific -> Either b Integer
floatingOrInteger = S.floatingOrInteger
asBool :: Parse err Bool
asBool = as patBool TyBool
asObject :: Parse err A.Object
asObject = as patObject TyObject
asArray :: Parse err A.Array
asArray = as patArray TyArray
asNull :: Parse err ()
asNull = as patNull TyNull
perhaps :: Parse err a -> Parse err (Maybe a)
perhaps p = do
v <- asks rdrValue
case v of
A.Null -> return Nothing
_ -> Just <$> p
key :: Text -> Parse err a -> Parse err a
key k p = key' (badSchema (KeyMissing k)) k p
keyOrDefault :: Text -> a -> Parse err a -> Parse err a
keyOrDefault k def p = key' (pure def) k p
keyMay :: Text -> Parse err a -> Parse err (Maybe a)
keyMay k p = keyOrDefault k Nothing (Just <$> p)
key' :: Parse err a -> Text -> Parse err a -> Parse err a
key' onMissing k p = do
v <- asks rdrValue
case v of
A.Object obj ->
case HashMap.lookup k obj of
Just v' ->
local (appendPath (ObjectKey k) . setValue v') p
Nothing ->
onMissing
_ ->
badSchema (WrongType TyObject v)
nth :: Int -> Parse err a -> Parse err a
nth n p = nth' (badSchema (OutOfBounds n)) n p
nthOrDefault :: Int -> a -> Parse err a -> Parse err a
nthOrDefault n def p =
nth' (pure def) n p
nthMay :: Int -> Parse err a -> Parse err (Maybe a)
nthMay n p = nthOrDefault n Nothing (Just <$> p)
nth' :: Parse err a -> Int -> Parse err a -> Parse err a
nth' onMissing n p = do
v <- asks rdrValue
case v of
A.Array vect ->
case vect !? n of
Just v' ->
local (appendPath (ArrayIndex n) . setValue v') p
Nothing ->
onMissing
_ ->
badSchema (WrongType TyArray v)
eachInArray :: Parse err a -> Parse err [a]
eachInArray p = do
xs <- zip [0..] . V.toList <$> asArray
forM xs $ \(i, x) ->
local (appendPath (ArrayIndex i) . setValue x) p
eachInObject :: Parse err a -> Parse err [(Text, a)]
eachInObject p = do
xs <- HashMap.toList <$> asObject
forM xs $ \(k, x) ->
(k,) <$> local (appendPath (ObjectKey k) . setValue x) p
eachInObjectWithKey :: (Text -> Either err k) -> Parse err a -> Parse err [(k, a)]
eachInObjectWithKey parseKey parseVal =
eachInObject parseVal
>>= mapM ((\(k,v) -> liftEither ((,) <$> parseKey k <*> pure v)))
withValue :: (A.Value -> Either err a) -> Parse err a
withValue f = liftParse (mapLeft CustomError . f)
liftEither :: Either err a -> Parse err a
liftEither = either (badSchema . CustomError) return
with :: Parse err a -> (a -> Either err b) -> Parse err b
with g f = g >>= liftEither . f
withText :: (Text -> Either err a) -> Parse err a
withText = with asText
withString :: (String -> Either err a) -> Parse err a
withString = with asString
withScientific :: (Scientific -> Either err a) -> Parse err a
withScientific = with asScientific
withIntegral :: Integral a => (a -> Either err b) -> Parse err b
withIntegral = with asIntegral
withRealFloat :: RealFloat a => (a -> Either err b) -> Parse err b
withRealFloat = with asRealFloat
withBool :: (Bool -> Either err a) -> Parse err a
withBool = with asBool
withObject :: (A.Object -> Either err a) -> Parse err a
withObject = with asObject
withArray :: (A.Array -> Either err a) -> Parse err a
withArray = with asArray
throwCustomError :: err -> Parse err a
throwCustomError = liftEither . Left