{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ViewPatterns               #-}
{-# LANGUAGE TemplateHaskell            #-}

-- | This module defines a JSON parser, like Aeson's 'FromJSON', but
-- with more detailed error-reporting capabilities.  In particular, it
-- reports errors in a structured format, and can report multiple
-- independent errors rather than stopping on the first one
-- encountered.
module Data.API.JSON
    ( -- * Parser with multiple error support
      ParserWithErrs
    , ParseFlags(useDefaults, enforceReadOnlyFields, enforceFilters)
    , defaultParseFlags
    , runParserWithErrsTop

      -- * FromJSON class with multiple error support
    , FromJSONWithErrs(..)
    , fromJSONWithErrs
    , fromJSONWithErrs'
    , fromJSONWithErrs''
    , decodeWithErrs
    , decodeWithErrs'
    , parseJSONDefault

      -- * ParserWithErrs combinators
    , withParseFlags
    , withInt
    , withIntRange
    , withBinary
    , withBool
    , withText
    , withRegEx
    , withUTC
    , withUTCRange
    , withVersion
    , withField
    , withDefaultField
    , (.:.)
    , (.::)
    , withUnion

      -- * Representation of JSON parsing errors
    , JSONError(..)
    , JSONWarning
    , Expected(..)
    , FormatExpected(..)
    , Position
    , Step(..)
    , prettyJSONErrorPositions
    , prettyJSONError
    , prettyStep

      -- * Error construction
    , failWith
    , expectedArray
    , expectedBool
    , expectedInt
    , expectedObject
    , expectedString
    , badFormat
    ) where

import           Data.API.Error
import           Data.API.JSON.Compat
import           Data.API.Time
import           Data.API.Types
import           Data.API.Utils

import           Control.Applicative
import qualified Control.Monad.Fail as Fail
import qualified Data.Aeson                     as JS
import qualified Data.Aeson.Parser              as JS
import qualified Data.Aeson.Types               as JS
import           Data.Attoparsec.ByteString
import qualified Data.ByteString.Char8          as B
import qualified Data.ByteString.Base64         as B64
import qualified Data.ByteString.Lazy           as BL
import           Data.Maybe
import qualified Data.Text                      as T
import qualified Data.Text.Encoding             as T
import           Data.Time
import           Data.Traversable
import qualified Data.Vector                    as V
import           Data.Version
import           Text.Regex
import           Prelude


----------------------------------------
-- Parser with multiple error support
--

-- | Like 'Parser', but keeping track of locations within the JSON
-- structure and able to report multiple errors.
--
-- Careful! The 'Monad' instance does not agree with the 'Applicative'
-- instance in all circumstances, and you should use the 'Applicative'
-- instance where possible.  In particular:
--
--    * @pf \<*\> ps@ returns errors from both arguments
--
--    * @pf \`ap\` ps@  returns errors from @pf@ only
newtype ParserWithErrs a = ParserWithErrs {
    forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs :: ParseFlags -> Position -> ([(JSONError, Position)], Maybe a) }
  deriving forall a b. a -> ParserWithErrs b -> ParserWithErrs a
forall a b. (a -> b) -> ParserWithErrs a -> ParserWithErrs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParserWithErrs b -> ParserWithErrs a
$c<$ :: forall a b. a -> ParserWithErrs b -> ParserWithErrs a
fmap :: forall a b. (a -> b) -> ParserWithErrs a -> ParserWithErrs b
$cfmap :: forall a b. (a -> b) -> ParserWithErrs a -> ParserWithErrs b
Functor

instance Applicative ParserWithErrs where
  pure :: forall a. a -> ParserWithErrs a
pure a
x    = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
_ Position
_ -> ([], forall a. a -> Maybe a
Just a
x)
  ParserWithErrs (a -> b)
pf <*> :: forall a b.
ParserWithErrs (a -> b) -> ParserWithErrs a -> ParserWithErrs b
<*> ParserWithErrs a
ps = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z ->
                  let ([(JSONError, Position)]
es_f, Maybe (a -> b)
mb_f) = forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs (a -> b)
pf ParseFlags
q Position
z
                      ([(JSONError, Position)]
es_s, Maybe a
mb_s) = forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
ps ParseFlags
q Position
z
                  in ([(JSONError, Position)]
es_f forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)]
es_s, Maybe (a -> b)
mb_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe a
mb_s)

instance Alternative ParserWithErrs where
  empty :: forall a. ParserWithErrs a
empty   = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
"No alternative"
  ParserWithErrs a
px <|> :: forall a. ParserWithErrs a -> ParserWithErrs a -> ParserWithErrs a
<|> ParserWithErrs a
py = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> case forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
px ParseFlags
q Position
z of
                                          r :: ([(JSONError, Position)], Maybe a)
r@([(JSONError, Position)]
_, Just a
_) -> ([(JSONError, Position)], Maybe a)
r
                                          ([(JSONError, Position)]
_, Maybe a
Nothing)  -> forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
py ParseFlags
q Position
z

instance Monad ParserWithErrs where
  return :: forall a. a -> ParserWithErrs a
return   = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParserWithErrs a
px >>= :: forall a b.
ParserWithErrs a -> (a -> ParserWithErrs b) -> ParserWithErrs b
>>= a -> ParserWithErrs b
f = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z ->
                  case forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
px ParseFlags
q Position
z of
                    ([(JSONError, Position)]
es, Just a
x ) -> let ([(JSONError, Position)]
es', Maybe b
r) = forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs (a -> ParserWithErrs b
f a
x) ParseFlags
q Position
z
                                     in ([(JSONError, Position)]
es forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)]
es', Maybe b
r)
                    ([(JSONError, Position)]
es, Maybe a
Nothing) -> ([(JSONError, Position)]
es, forall a. Maybe a
Nothing)
#if !(MIN_VERSION_base(4,13,0))
  fail = Fail.fail
#endif

instance Fail.MonadFail ParserWithErrs where
  fail :: forall a. String -> ParserWithErrs a
fail     = forall a. JSONError -> ParserWithErrs a
failWith forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSONError
SyntaxError


-- | Options to modify the behaviour of the JSON parser
data ParseFlags = ParseFlags
    { ParseFlags -> Bool
useDefaults           :: Bool
      -- ^ If true, default values from the schema will be used when a
      -- field is missing from the JSON data
    , ParseFlags -> Bool
enforceReadOnlyFields :: Bool
      -- ^ If true, fields in the schema marked read-only will be
      -- overwritten with default values
    , ParseFlags -> Bool
enforceFilters        :: Bool
      -- ^ If true, parse errors will be generated when invalid values
      -- are supplied for filtered newtypes
    }

-- | Use this as a basis for overriding individual fields of the
-- 'ParseFlags' record, in case more flags are added in the future.
defaultParseFlags :: ParseFlags
defaultParseFlags :: ParseFlags
defaultParseFlags = ParseFlags { useDefaults :: Bool
useDefaults           = Bool
False
                               , enforceReadOnlyFields :: Bool
enforceReadOnlyFields = Bool
False
                               , enforceFilters :: Bool
enforceFilters        = Bool
True
                               }

-- | Run a parser with given flags, starting in the outermost
-- location, and returning warnings even if the parse was successful
runParserWithErrsTop :: ParseFlags -> ParserWithErrs a
                      -> Either [(JSONError, Position)] (a, [(JSONWarning, Position)])
runParserWithErrsTop :: forall a.
ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
runParserWithErrsTop ParseFlags
q ParserWithErrs a
p = case forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
p ParseFlags
q [] of
                              ([(JSONError, Position)]
es, Maybe a
Nothing) -> forall a b. a -> Either a b
Left [(JSONError, Position)]
es
                              ([(JSONError, Position)]
es, Just a
v)  -> forall a b. b -> Either a b
Right (a
v, [(JSONError, Position)]
es)


--------------------------------------------------
-- FromJSON class with multiple error support
--

-- | Like 'FromJSON', but keeping track of multiple errors and their
-- positions.  Moreover, this class is more liberal in accepting
-- invalid inputs:
--
-- * a string like @\"3\"@ is accepted as an integer; and
--
-- * the integers @0@ and @1@ are accepted as booleans.

class FromJSONWithErrs a where
  -- | Parse a JSON value with structured error-reporting support.  If
  -- this method is omitted, 'fromJSON' will be used instead: note
  -- that this will result in less precise errors.
  parseJSONWithErrs :: JS.Value -> ParserWithErrs a
  default parseJSONWithErrs :: JS.FromJSON a => JS.Value -> ParserWithErrs a
  parseJSONWithErrs Value
v = case forall a. FromJSON a => Value -> Result a
JS.fromJSON Value
v of
                      JS.Error String
e   -> forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
e
                      JS.Success a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

instance FromJSONWithErrs JS.Value where
  parseJSONWithErrs :: Value -> ParserWithErrs Value
parseJSONWithErrs = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs () where
  parseJSONWithErrs :: Value -> ParserWithErrs ()
parseJSONWithErrs (JS.Array Array
a) | forall a. Vector a -> Bool
V.null Array
a  = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  parseJSONWithErrs Value
_                        = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
"Expected empty array"

instance FromJSONWithErrs a => FromJSONWithErrs (Maybe a) where
  parseJSONWithErrs :: Value -> ParserWithErrs (Maybe a)
parseJSONWithErrs Value
JS.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  parseJSONWithErrs Value
v       = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs Value
v

instance FromJSONWithErrs a => FromJSONWithErrs [a] where
  parseJSONWithErrs :: Value -> ParserWithErrs [a]
parseJSONWithErrs (JS.Array Array
a) = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. FromJSONWithErrs a => (Value, Int) -> ParserWithErrs a
help forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Vector a -> [a]
V.toList Array
a) [Int
0..]
    where
      help :: (Value, Int) -> ParserWithErrs a
help (Value
x, Int
i) = forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Int -> Step
InElem Int
i) forall a b. (a -> b) -> a -> b
$ forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs Value
x
  parseJSONWithErrs Value
JS.Null      = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  parseJSONWithErrs Value
v            = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v

instance FromJSONWithErrs Int where
  parseJSONWithErrs :: Value -> ParserWithErrs Int
parseJSONWithErrs = forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt String
"Int" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs Integer where
  parseJSONWithErrs :: Value -> ParserWithErrs Integer
parseJSONWithErrs = forall n a.
Integral n =>
String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
withNum String
"Integer" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs Bool where
  parseJSONWithErrs :: Value -> ParserWithErrs Bool
parseJSONWithErrs = forall a.
String -> (Bool -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBool String
"Bool" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs Binary where
  parseJSONWithErrs :: Value -> ParserWithErrs Binary
parseJSONWithErrs = forall a.
String -> (Binary -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBinary String
"Binary" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs T.Text where
  parseJSONWithErrs :: Value -> ParserWithErrs Text
parseJSONWithErrs = forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
"Text" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs UTCTime where
  parseJSONWithErrs :: Value -> ParserWithErrs UTCTime
parseJSONWithErrs = forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC String
"UTC" forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromJSONWithErrs Version where
  parseJSONWithErrs :: Value -> ParserWithErrs Version
parseJSONWithErrs = forall a.
String
-> (Version -> ParserWithErrs a) -> Value -> ParserWithErrs a
withVersion String
"Version" forall (f :: * -> *) a. Applicative f => a -> f a
pure


-- | Run the JSON parser on a value to produce a result or a list of
-- errors with their positions.  This should not be used inside an
-- implementation of 'parseJSONWithErrs' as it will not pass on the
-- current position.
fromJSONWithErrs :: FromJSONWithErrs a => JS.Value -> Either [(JSONError, Position)] a
fromJSONWithErrs :: forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs = forall a.
FromJSONWithErrs a =>
ParseFlags -> Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' ParseFlags
defaultParseFlags

-- | Run the JSON parser on a value to produce a result or a list of
-- errors with their positions.  This version allows the 'ParseFlags'
-- to be specified.
fromJSONWithErrs' :: FromJSONWithErrs a => ParseFlags -> JS.Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' :: forall a.
FromJSONWithErrs a =>
ParseFlags -> Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' ParseFlags
q = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
FromJSONWithErrs a =>
ParseFlags
-> Value
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
fromJSONWithErrs'' ParseFlags
q

-- | Run the JSON parser on a value to produce a result or a list of
-- errors with their positions.  This version allows the 'ParseFlags'
-- to be specified, and produces warnings even if the parse succeeded.
fromJSONWithErrs'' :: FromJSONWithErrs a => ParseFlags -> JS.Value
                   -> Either [(JSONError, Position)] (a, [(JSONWarning, Position)])
fromJSONWithErrs'' :: forall a.
FromJSONWithErrs a =>
ParseFlags
-> Value
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
fromJSONWithErrs'' ParseFlags
q = forall a.
ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
runParserWithErrsTop ParseFlags
q forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs


-- | Decode a 'ByteString' and run the JSON parser
decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a
decodeWithErrs :: forall a.
FromJSONWithErrs a =>
ByteString -> Either [(JSONError, Position)] a
decodeWithErrs = forall a.
FromJSONWithErrs a =>
ParseFlags -> ByteString -> Either [(JSONError, Position)] a
decodeWithErrs' ParseFlags
defaultParseFlags

-- | Decode a 'ByteString' and run the JSON parser, allowing the
-- 'ParseFlags' to be specified
decodeWithErrs' :: FromJSONWithErrs a => ParseFlags -> BL.ByteString -> Either [(JSONError, Position)] a
decodeWithErrs' :: forall a.
FromJSONWithErrs a =>
ParseFlags -> ByteString -> Either [(JSONError, Position)] a
decodeWithErrs' ParseFlags
q ByteString
x = case forall a. FromJSON a => ByteString -> Either String a
JS.eitherDecode ByteString
x of
                     Left String
e  -> forall a b. a -> Either a b
Left [(String -> JSONError
SyntaxError String
e, [])]
                     Right Value
v -> forall a.
FromJSONWithErrs a =>
ParseFlags -> Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' ParseFlags
q Value
v


-- | Suitable as an implementation of 'parseJSON' that uses the
-- 'FromJSONWithErrs' instance (provided said instance was not defined
-- using 'fromJSON'!).
parseJSONDefault :: FromJSONWithErrs a => JS.Value -> JS.Parser a
parseJSONDefault :: forall a. FromJSONWithErrs a => Value -> Parser a
parseJSONDefault Value
v = case forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs Value
v of
                       Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                       Left [(JSONError, Position)]
es -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ [(JSONError, Position)] -> String
prettyJSONErrorPositions [(JSONError, Position)]
es


---------------------------------
-- ParserWithErrs combinators
--

withParseFlags :: (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags :: forall a. (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags ParseFlags -> ParserWithErrs a
k = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q -> forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs (ParseFlags -> ParserWithErrs a
k ParseFlags
q) ParseFlags
q

failWith :: JSONError -> ParserWithErrs a
failWith :: forall a. JSONError -> ParserWithErrs a
failWith JSONError
e = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
_ Position
z -> ([(JSONError
e, Position
z)], forall a. Maybe a
Nothing)

warning :: JSONError -> ParserWithErrs ()
warning :: JSONError -> ParserWithErrs ()
warning JSONError
e = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
_ Position
z -> ([(JSONError
e, Position
z)], forall a. a -> Maybe a
Just ())

stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a
stepInside :: forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside Step
s ParserWithErrs a
p = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
p ParseFlags
q (Step
sforall a. a -> [a] -> [a]
:Position
z)

-- | If this parser returns any errors at the current position, modify
-- them using the supplied function.
modifyTopError :: (JSONError -> JSONError)
               -> ParserWithErrs a -> ParserWithErrs a
modifyTopError :: forall a.
(JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
f ParserWithErrs a
p = forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> case forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
p ParseFlags
q Position
z of
                                                 ([(JSONError, Position)]
es, Maybe a
r) -> (forall a b. (a -> b) -> [a] -> [b]
map (forall {b}. Eq b => b -> (JSONError, b) -> (JSONError, b)
modifyIfAt Position
z) [(JSONError, Position)]
es, Maybe a
r)
  where
    modifyIfAt :: b -> (JSONError, b) -> (JSONError, b)
modifyIfAt b
z x :: (JSONError, b)
x@(JSONError
e, b
z') | b
z forall a. Eq a => a -> a -> Bool
== b
z'   = (JSONError -> JSONError
f JSONError
e, b
z')
                           | Bool
otherwise = (JSONError, b)
x

-- | If the conditional is false, fail with an error (if filters are
-- not being enforced) or report a warning and continue (if they are).
withFilter :: Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter :: forall a. Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter Bool
p JSONError
err ParserWithErrs a
m | Bool
p         = ParserWithErrs a
m
                   | Bool
otherwise = forall a. (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags forall a b. (a -> b) -> a -> b
$ \ ParseFlags
pf -> if ParseFlags -> Bool
enforceFilters ParseFlags
pf then forall a. JSONError -> ParserWithErrs a
failWith JSONError
err
                                                                               else JSONError -> ParserWithErrs ()
warning JSONError
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParserWithErrs a
m


-- | It's contrary to my principles, but I'll accept a string containing
-- a number instead of an actual number, and will silently truncate
-- floating point numbers to integers...
withInt :: String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withInt :: forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt = forall n a.
Integral n =>
String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
withNum

withNum :: Integral n => String -> (n -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withNum :: forall n a.
Integral n =>
String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
withNum String
_ n -> ParserWithErrs a
f (JS.Number Scientific
n) = n -> ParserWithErrs a
f (forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
n)
withNum String
s n -> ParserWithErrs a
f (JS.String Text
t)
  | Right Value
v' <- forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser ByteString Value
JS.value forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) (Text -> ByteString
T.encodeUtf8 Text
t) = forall n a.
Integral n =>
String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
withNum String
s n -> ParserWithErrs a
f Value
v'
withNum String
s n -> ParserWithErrs a
_ Value
v = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpInt String
s Value
v

withIntRange :: IntRange -> String -> (Int -> ParserWithErrs a)
             -> JS.Value -> ParserWithErrs a
withIntRange :: forall a.
IntRange
-> String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withIntRange IntRange
ir String
dg Int -> ParserWithErrs a
f = forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt String
dg forall a b. (a -> b) -> a -> b
$ \ Int
i -> forall a. Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter (Int
i Int -> IntRange -> Bool
`inIntRange` IntRange
ir) (String -> Int -> IntRange -> JSONError
IntRangeError String
dg Int
i IntRange
ir) (Int -> ParserWithErrs a
f Int
i)

withBinary :: String -> (Binary -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a
withBinary :: forall a.
String -> (Binary -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBinary String
lab Binary -> ParserWithErrs a
f = forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
lab Text -> ParserWithErrs a
g
  where
    g :: Text -> ParserWithErrs a
g Text
t =
        case ByteString -> Either String ByteString
B64.decode forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t of
          Left  String
_  -> forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ FormatExpected -> String -> Text -> JSONError
BadFormat FormatExpected
FmtBinary String
lab Text
t
          Right ByteString
bs -> Binary -> ParserWithErrs a
f forall a b. (a -> b) -> a -> b
$ ByteString -> Binary
Binary ByteString
bs

-- Everyone knows 0 and 1 are booleans really...
withBool :: String -> (Bool -> ParserWithErrs a)
         -> JS.Value -> ParserWithErrs a
withBool :: forall a.
String -> (Bool -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBool String
_ Bool -> ParserWithErrs a
f (JS.Bool Bool
b) = Bool -> ParserWithErrs a
f Bool
b
withBool String
_ Bool -> ParserWithErrs a
f (JS.Number Scientific
x) | Scientific
x forall a. Eq a => a -> a -> Bool
== Scientific
0 = Bool -> ParserWithErrs a
f Bool
False
                           | Scientific
x forall a. Eq a => a -> a -> Bool
== Scientific
1 = Bool -> ParserWithErrs a
f Bool
True
withBool String
s Bool -> ParserWithErrs a
_ Value
v                      = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpBool String
s Value
v

withText :: String -> (T.Text -> ParserWithErrs a)
         -> JS.Value -> ParserWithErrs a
withText :: forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
_ Text -> ParserWithErrs a
f (JS.String Text
t) = Text -> ParserWithErrs a
f Text
t
withText String
s Text -> ParserWithErrs a
_ Value
v             = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpString String
s Value
v

withRegEx :: RegEx -> String -> (T.Text -> ParserWithErrs a)
               -> JS.Value -> ParserWithErrs a
withRegEx :: forall a.
RegEx
-> String
-> (Text -> ParserWithErrs a)
-> Value
-> ParserWithErrs a
withRegEx RegEx
re String
dg Text -> ParserWithErrs a
f = forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
dg forall a b. (a -> b) -> a -> b
$ \ Text
txt -> forall a. Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter (Text -> Bool
ok Text
txt) (String -> Text -> RegEx -> JSONError
RegexError String
dg Text
txt RegEx
re) (Text -> ParserWithErrs a
f Text
txt)
  where
    ok :: Text -> Bool
ok Text
txt = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Regex -> String -> Maybe [String]
matchRegex (RegEx -> Regex
re_regex RegEx
re) forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt

withUTC :: String -> (UTCTime -> ParserWithErrs a)
        -> JS.Value -> ParserWithErrs a
withUTC :: forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC String
lab UTCTime -> ParserWithErrs a
f = forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
lab Text -> ParserWithErrs a
g
  where
    g :: Text -> ParserWithErrs a
g Text
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ FormatExpected -> String -> Text -> JSONError
BadFormat FormatExpected
FmtUTC String
lab Text
t) UTCTime -> ParserWithErrs a
f forall a b. (a -> b) -> a -> b
$ Text -> Maybe UTCTime
parseUTC Text
t

withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a)
               -> JS.Value -> ParserWithErrs a
withUTCRange :: forall a.
UTCRange
-> String
-> (UTCTime -> ParserWithErrs a)
-> Value
-> ParserWithErrs a
withUTCRange UTCRange
ur String
dg UTCTime -> ParserWithErrs a
f = forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC String
dg forall a b. (a -> b) -> a -> b
$ \ UTCTime
u -> forall a. Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter (UTCTime
u UTCTime -> UTCRange -> Bool
`inUTCRange` UTCRange
ur) (String -> UTCTime -> UTCRange -> JSONError
UTCRangeError String
dg UTCTime
u UTCRange
ur) (UTCTime -> ParserWithErrs a
f UTCTime
u)

withVersion :: String -> (Version -> ParserWithErrs a)
            -> JS.Value -> ParserWithErrs a
withVersion :: forall a.
String
-> (Version -> ParserWithErrs a) -> Value -> ParserWithErrs a
withVersion String
lab Version -> ParserWithErrs a
f (JS.String Text
s) = case String -> Maybe Version
simpleParseVersion (Text -> String
T.unpack Text
s) of
                                    Just Version
ver -> Version -> ParserWithErrs a
f Version
ver
                                    Maybe Version
Nothing  -> forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ String -> Text -> JSONError
badFormat String
lab Text
s
withVersion String
lab Version -> ParserWithErrs a
_ Value
v             = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpString String
lab Value
v

-- | Look up the value of a field, treating missing fields as null
withField :: T.Text -> (JS.Value -> ParserWithErrs a)
          -> JS.Object -> ParserWithErrs a
withField :: forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withField Text
k Value -> ParserWithErrs a
f Object
m = forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) forall a b. (a -> b) -> a -> b
$ forall a.
(JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
treatAsMissing forall a b. (a -> b) -> a -> b
$ Value -> ParserWithErrs a
f Value
v
  where
    v :: Value
v = forall a. a -> Maybe a -> a
fromMaybe Value
JS.Null forall a b. (a -> b) -> a -> b
$ forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
k Object
m

treatAsMissing :: JSONError -> JSONError
treatAsMissing :: JSONError -> JSONError
treatAsMissing (Expected Expected
_ String
_ Value
JS.Null) = JSONError
MissingField
treatAsMissing JSONError
e                      = JSONError
e

-- | Look up the value of a field, which may be read-only or use a
-- default value (depending on the 'ParseFlags').
withDefaultField :: Bool -> Maybe JS.Value -> T.Text -> (JS.Value -> ParserWithErrs a)
                 -> JS.Object -> ParserWithErrs a
withDefaultField :: forall a.
Bool
-> Maybe Value
-> Text
-> (Value -> ParserWithErrs a)
-> Object
-> ParserWithErrs a
withDefaultField Bool
readOnly Maybe Value
mb_defVal Text
k Value -> ParserWithErrs a
f Object
m =
    forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) forall a b. (a -> b) -> a -> b
$ forall a.
(JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
treatAsMissing forall a b. (a -> b) -> a -> b
$ forall a. (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags ParseFlags -> ParserWithErrs a
foo
  where
    foo :: ParseFlags -> ParserWithErrs a
foo ParseFlags
q | Bool
readOnly Bool -> Bool -> Bool
&& ParseFlags -> Bool
enforceReadOnlyFields ParseFlags
q = Value -> ParserWithErrs a
f Value
defVal
          | ParseFlags -> Bool
useDefaults ParseFlags
q                       = Value -> ParserWithErrs a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Value
defVal  forall a b. (a -> b) -> a -> b
$ forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
k Object
m
          | Bool
otherwise                           = Value -> ParserWithErrs a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Value
JS.Null forall a b. (a -> b) -> a -> b
$ forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
k Object
m

    defVal :: Value
defVal = forall a. a -> Maybe a -> a
fromMaybe Value
JS.Null Maybe Value
mb_defVal

-- | Look up the value of a field, failing on missing fields
withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a)
          -> JS.Object -> ParserWithErrs a
withStrictField :: forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withStrictField Text
k Value -> ParserWithErrs a
f Object
m = forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) forall a b. (a -> b) -> a -> b
$ case forall a. Text -> KeyMap a -> Maybe a
lookupKey Text
k Object
m of
                            Maybe Value
Nothing -> forall a. JSONError -> ParserWithErrs a
failWith JSONError
MissingField
                            Just Value
r  -> Value -> ParserWithErrs a
f Value
r

-- | Parse the value of a field, treating missing fields as null
(.:.) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a
Object
m .:. :: forall a. FromJSONWithErrs a => Object -> Text -> ParserWithErrs a
.:. Text
k = forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withField Text
k forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs Object
m

-- | Parse the value of a field, failing on missing fields
(.::) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a
Object
m .:: :: forall a. FromJSONWithErrs a => Object -> Text -> ParserWithErrs a
.:: Text
k = forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withStrictField Text
k forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs Object
m


-- | Match an inhabitant of a disjoint union, which should be an
-- object with a single field, and call the continuation corresponding
-- to the field name.
withUnion :: [(T.Text, JS.Value -> ParserWithErrs a)] -> JS.Value -> ParserWithErrs a
withUnion :: forall a.
[(Text, Value -> ParserWithErrs a)] -> Value -> ParserWithErrs a
withUnion [(Text, Value -> ParserWithErrs a)]
xs (JS.Object Object
hs) =
   case forall a. KeyMap a -> [(Text, a)]
objectToList Object
hs of
      [(Text
k, Value
v)] -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Value -> ParserWithErrs a)]
xs of
                    Just Value -> ParserWithErrs a
c  -> forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) forall a b. (a -> b) -> a -> b
$ Value -> ParserWithErrs a
c Value
v
                    Maybe (Value -> ParserWithErrs a)
Nothing -> forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ [String] -> JSONError
MissingAlt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Value -> ParserWithErrs a)]
xs
      []       -> forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ [String] -> JSONError
MissingAlt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, Value -> ParserWithErrs a)]
xs
      (Text, Value)
_:(Text, Value)
_:[(Text, Value)]
_    -> forall a. JSONError -> ParserWithErrs a
failWith JSONError
UnexpectedField
withUnion [(Text, Value -> ParserWithErrs a)]
_ Value
val = forall a. JSONError -> ParserWithErrs a
failWith forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"Union" Value
val