{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# 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.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 qualified Data.HashMap.Strict            as HMap
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 {
    ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs :: ParseFlags -> Position -> ([(JSONError, Position)], Maybe a) }
  deriving a -> ParserWithErrs b -> ParserWithErrs a
(a -> b) -> ParserWithErrs a -> ParserWithErrs b
(forall a b. (a -> b) -> ParserWithErrs a -> ParserWithErrs b)
-> (forall a b. a -> ParserWithErrs b -> ParserWithErrs a)
-> Functor ParserWithErrs
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
<$ :: a -> ParserWithErrs b -> ParserWithErrs a
$c<$ :: forall a b. a -> ParserWithErrs b -> ParserWithErrs a
fmap :: (a -> b) -> ParserWithErrs a -> ParserWithErrs b
$cfmap :: forall a b. (a -> b) -> ParserWithErrs a -> ParserWithErrs b
Functor

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

instance Alternative ParserWithErrs where
  empty :: ParserWithErrs a
empty   = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
"No alternative"
  ParserWithErrs a
px <|> :: ParserWithErrs a -> ParserWithErrs a -> ParserWithErrs a
<|> ParserWithErrs a
py = (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs ((ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
 -> ParserWithErrs a)
-> (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> case ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
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)  -> ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
py ParseFlags
q Position
z

instance Monad ParserWithErrs where
  return :: a -> ParserWithErrs a
return   = a -> ParserWithErrs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParserWithErrs a
px >>= :: ParserWithErrs a -> (a -> ParserWithErrs b) -> ParserWithErrs b
>>= a -> ParserWithErrs b
f = (ParseFlags -> Position -> ([(JSONError, Position)], Maybe b))
-> ParserWithErrs b
forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs ((ParseFlags -> Position -> ([(JSONError, Position)], Maybe b))
 -> ParserWithErrs b)
-> (ParseFlags -> Position -> ([(JSONError, Position)], Maybe b))
-> ParserWithErrs b
forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z ->
                  case ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
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) = ParserWithErrs b
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe b)
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 [(JSONError, Position)]
-> [(JSONError, Position)] -> [(JSONError, Position)]
forall a. [a] -> [a] -> [a]
++ [(JSONError, Position)]
es', Maybe b
r)
                    ([(JSONError, Position)]
es, Maybe a
Nothing) -> ([(JSONError, Position)]
es, Maybe b
forall a. Maybe a
Nothing)
#if !(MIN_VERSION_base(4,13,0))
  fail = Fail.fail
#endif

instance Fail.MonadFail ParserWithErrs where
  fail :: String -> ParserWithErrs a
fail     = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a)
-> (String -> JSONError) -> String -> ParserWithErrs a
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 :: Bool -> Bool -> Bool -> ParseFlags
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 :: ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
runParserWithErrsTop ParseFlags
q ParserWithErrs a
p = case ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
p ParseFlags
q [] of
                              ([(JSONError, Position)]
es, Maybe a
Nothing) -> [(JSONError, Position)]
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
forall a b. a -> Either a b
Left [(JSONError, Position)]
es
                              ([(JSONError, Position)]
es, Just a
v)  -> (a, [(JSONError, Position)])
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
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 Value -> Result a
forall a. FromJSON a => Value -> Result a
JS.fromJSON Value
v of
                      JS.Error String
e   -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ String -> JSONError
SyntaxError String
e
                      JS.Success a
a -> a -> ParserWithErrs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

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

instance FromJSONWithErrs () where
  parseJSONWithErrs :: Value -> ParserWithErrs ()
parseJSONWithErrs (JS.Array Array
a) | Array -> Bool
forall a. Vector a -> Bool
V.null Array
a  = () -> ParserWithErrs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  parseJSONWithErrs Value
_                        = JSONError -> ParserWithErrs ()
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs ()) -> JSONError -> ParserWithErrs ()
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 = Maybe a -> ParserWithErrs (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  parseJSONWithErrs Value
v       = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> ParserWithErrs a -> ParserWithErrs (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> ParserWithErrs a
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) = ((Value, Int) -> ParserWithErrs a)
-> [(Value, Int)] -> ParserWithErrs [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Value, Int) -> ParserWithErrs a
forall a. FromJSONWithErrs a => (Value, Int) -> ParserWithErrs a
help ([(Value, Int)] -> ParserWithErrs [a])
-> [(Value, Int)] -> ParserWithErrs [a]
forall a b. (a -> b) -> a -> b
$ [Value] -> [Int] -> [(Value, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
a) [Int
0..]
    where
      help :: (Value, Int) -> ParserWithErrs a
help (Value
x, Int
i) = Step -> ParserWithErrs a -> ParserWithErrs a
forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Int -> Step
InElem Int
i) (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> ParserWithErrs a
forall a. FromJSONWithErrs a => Value -> ParserWithErrs a
parseJSONWithErrs Value
x
  parseJSONWithErrs Value
JS.Null      = [a] -> ParserWithErrs [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  parseJSONWithErrs Value
v            = JSONError -> ParserWithErrs [a]
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs [a])
-> JSONError -> ParserWithErrs [a]
forall a b. (a -> b) -> a -> b
$ Value -> JSONError
expectedArray Value
v

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

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

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

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

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

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

instance FromJSONWithErrs Version where
  parseJSONWithErrs :: Value -> ParserWithErrs Version
parseJSONWithErrs = String
-> (Version -> ParserWithErrs Version)
-> Value
-> ParserWithErrs Version
forall a.
String
-> (Version -> ParserWithErrs a) -> Value -> ParserWithErrs a
withVersion String
"Version" Version -> ParserWithErrs 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 :: Value -> Either [(JSONError, Position)] a
fromJSONWithErrs = ParseFlags -> Value -> Either [(JSONError, Position)] a
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' :: ParseFlags -> Value -> Either [(JSONError, Position)] a
fromJSONWithErrs' ParseFlags
q = ((a, [(JSONError, Position)]) -> a)
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
-> Either [(JSONError, Position)] a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, [(JSONError, Position)]) -> a
forall a b. (a, b) -> a
fst (Either [(JSONError, Position)] (a, [(JSONError, Position)])
 -> Either [(JSONError, Position)] a)
-> (Value
    -> Either [(JSONError, Position)] (a, [(JSONError, Position)]))
-> Value
-> Either [(JSONError, Position)] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseFlags
-> Value
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
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'' :: ParseFlags
-> Value
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
fromJSONWithErrs'' ParseFlags
q = ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
forall a.
ParseFlags
-> ParserWithErrs a
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
runParserWithErrsTop ParseFlags
q (ParserWithErrs a
 -> Either [(JSONError, Position)] (a, [(JSONError, Position)]))
-> (Value -> ParserWithErrs a)
-> Value
-> Either [(JSONError, Position)] (a, [(JSONError, Position)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ParserWithErrs a
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 :: ByteString -> Either [(JSONError, Position)] a
decodeWithErrs = ParseFlags -> ByteString -> Either [(JSONError, Position)] a
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' :: ParseFlags -> ByteString -> Either [(JSONError, Position)] a
decodeWithErrs' ParseFlags
q ByteString
x = case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
JS.eitherDecode ByteString
x of
                     Left String
e  -> [(JSONError, Position)] -> Either [(JSONError, Position)] a
forall a b. a -> Either a b
Left [(String -> JSONError
SyntaxError String
e, [])]
                     Right Value
v -> ParseFlags -> Value -> Either [(JSONError, Position)] a
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 :: Value -> Parser a
parseJSONDefault Value
v = case Value -> Either [(JSONError, Position)] a
forall a.
FromJSONWithErrs a =>
Value -> Either [(JSONError, Position)] a
fromJSONWithErrs Value
v of
                       Right a
x -> a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
                       Left [(JSONError, Position)]
es -> String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ [(JSONError, Position)] -> String
prettyJSONErrorPositions [(JSONError, Position)]
es


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

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

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

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

stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a
stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a
stepInside Step
s ParserWithErrs a
p = (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs ((ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
 -> ParserWithErrs a)
-> (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
forall a.
ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
runParserWithErrs ParserWithErrs a
p ParseFlags
q (Step
sStep -> Position -> Position
forall 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 :: (JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
f ParserWithErrs a
p = (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a.
(ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
ParserWithErrs ((ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
 -> ParserWithErrs a)
-> (ParseFlags -> Position -> ([(JSONError, Position)], Maybe a))
-> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ ParseFlags
q Position
z -> case ParserWithErrs a
-> ParseFlags -> Position -> ([(JSONError, Position)], Maybe a)
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) -> (((JSONError, Position) -> (JSONError, Position))
-> [(JSONError, Position)] -> [(JSONError, Position)]
forall a b. (a -> b) -> [a] -> [b]
map (Position -> (JSONError, Position) -> (JSONError, Position)
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 b -> b -> Bool
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 :: Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
withFilter Bool
p JSONError
err ParserWithErrs a
m | Bool
p         = ParserWithErrs a
m
                   | Bool
otherwise = (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
forall a. (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
withParseFlags ((ParseFlags -> ParserWithErrs a) -> ParserWithErrs a)
-> (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ ParseFlags
pf -> if ParseFlags -> Bool
enforceFilters ParseFlags
pf then JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith JSONError
err
                                                                               else JSONError -> ParserWithErrs ()
warning JSONError
err ParserWithErrs () -> ParserWithErrs a -> ParserWithErrs a
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 :: String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt = String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
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 :: String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
withNum String
_ n -> ParserWithErrs a
f (JS.Number Scientific
n) = n -> ParserWithErrs a
f (Scientific -> n
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' <- Parser Value -> ByteString -> Either String Value
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser Value
JS.value Parser Value -> Parser ByteString () -> Parser Value
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput) (Text -> ByteString
T.encodeUtf8 Text
t) = String -> (n -> ParserWithErrs a) -> Value -> ParserWithErrs a
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 = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
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 :: IntRange
-> String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withIntRange IntRange
ir String
dg Int -> ParserWithErrs a
f = String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a.
String -> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
withInt String
dg ((Int -> ParserWithErrs a) -> Value -> ParserWithErrs a)
-> (Int -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ Int
i -> Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
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 :: String -> (Binary -> ParserWithErrs a) -> Value -> ParserWithErrs a
withBinary String
lab Binary -> ParserWithErrs a
f = String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
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 (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t of
          Left  String
_  -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
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 (Binary -> ParserWithErrs a) -> Binary -> ParserWithErrs a
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 :: 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 Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
0 = Bool -> ParserWithErrs a
f Bool
False
                           | Scientific
x Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
1 = Bool -> ParserWithErrs a
f Bool
True
withBool String
s Bool -> ParserWithErrs a
_ Value
v                      = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
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 :: 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             = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
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 :: RegEx
-> String
-> (Text -> ParserWithErrs a)
-> Value
-> ParserWithErrs a
withRegEx RegEx
re String
dg Text -> ParserWithErrs a
f = String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a.
String -> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
withText String
dg ((Text -> ParserWithErrs a) -> Value -> ParserWithErrs a)
-> (Text -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ Text
txt -> Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
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 = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [String] -> Bool) -> Maybe [String] -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> String -> Maybe [String]
matchRegex (RegEx -> Regex
re_regex RegEx
re) (String -> Maybe [String]) -> String -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt

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

withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a)
               -> JS.Value -> ParserWithErrs a
withUTCRange :: UTCRange
-> String
-> (UTCTime -> ParserWithErrs a)
-> Value
-> ParserWithErrs a
withUTCRange UTCRange
ur String
dg UTCTime -> ParserWithErrs a
f = String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a.
String
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
withUTC String
dg ((UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a)
-> (UTCTime -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ \ UTCTime
u -> Bool -> JSONError -> ParserWithErrs a -> ParserWithErrs a
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 :: 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  -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ String -> Text -> JSONError
badFormat String
lab Text
s
withVersion String
lab Version -> ParserWithErrs a
_ Value
v             = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
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 :: Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withField Text
k Value -> ParserWithErrs a
f Object
m = Step -> ParserWithErrs a -> ParserWithErrs a
forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ (JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
forall a.
(JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
treatAsMissing (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> ParserWithErrs a
f Value
v
  where
    v :: Value
v = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
JS.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup 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 :: 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 =
    Step -> ParserWithErrs a -> ParserWithErrs a
forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ (JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
forall a.
(JSONError -> JSONError) -> ParserWithErrs a -> ParserWithErrs a
modifyTopError JSONError -> JSONError
treatAsMissing (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ (ParseFlags -> ParserWithErrs a) -> ParserWithErrs a
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 (Value -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
defVal  (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
k Object
m
          | Bool
otherwise                           = Value -> ParserWithErrs a
f (Value -> ParserWithErrs a) -> Value -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
JS.Null (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
k Object
m

    defVal :: Value
defVal = Value -> Maybe Value -> Value
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 :: Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withStrictField Text
k Value -> ParserWithErrs a
f Object
m = Step -> ParserWithErrs a -> ParserWithErrs a
forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HMap.lookup Text
k Object
m of
                            Maybe Value
Nothing -> JSONError -> ParserWithErrs a
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 .:. :: Object -> Text -> ParserWithErrs a
.:. Text
k = Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withField Text
k Value -> ParserWithErrs a
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 .:: :: Object -> Text -> ParserWithErrs a
.:: Text
k = Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
forall a.
Text -> (Value -> ParserWithErrs a) -> Object -> ParserWithErrs a
withStrictField Text
k Value -> ParserWithErrs a
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 :: [(Text, Value -> ParserWithErrs a)] -> Value -> ParserWithErrs a
withUnion [(Text, Value -> ParserWithErrs a)]
xs (JS.Object Object
hs) =
   case Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList Object
hs of
      [(Text
k, Value
v)] -> case Text
-> [(Text, Value -> ParserWithErrs a)]
-> Maybe (Value -> ParserWithErrs a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Value -> ParserWithErrs a)]
xs of
                    Just Value -> ParserWithErrs a
c  -> Step -> ParserWithErrs a -> ParserWithErrs a
forall a. Step -> ParserWithErrs a -> ParserWithErrs a
stepInside (Text -> Step
InField Text
k) (ParserWithErrs a -> ParserWithErrs a)
-> ParserWithErrs a -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Value -> ParserWithErrs a
c Value
v
                    Maybe (Value -> ParserWithErrs a)
Nothing -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ [String] -> JSONError
MissingAlt ([String] -> JSONError) -> [String] -> JSONError
forall a b. (a -> b) -> a -> b
$ ((Text, Value -> ParserWithErrs a) -> String)
-> [(Text, Value -> ParserWithErrs a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String)
-> ((Text, Value -> ParserWithErrs a) -> Text)
-> (Text, Value -> ParserWithErrs a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value -> ParserWithErrs a) -> Text
forall a b. (a, b) -> a
fst) [(Text, Value -> ParserWithErrs a)]
xs
      []       -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ [String] -> JSONError
MissingAlt ([String] -> JSONError) -> [String] -> JSONError
forall a b. (a -> b) -> a -> b
$ ((Text, Value -> ParserWithErrs a) -> String)
-> [(Text, Value -> ParserWithErrs a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String)
-> ((Text, Value -> ParserWithErrs a) -> Text)
-> (Text, Value -> ParserWithErrs a)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value -> ParserWithErrs a) -> Text
forall a b. (a, b) -> a
fst) [(Text, Value -> ParserWithErrs a)]
xs
      (Text, Value)
_:(Text, Value)
_:[(Text, Value)]
_    -> JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith JSONError
UnexpectedField
withUnion [(Text, Value -> ParserWithErrs a)]
_ Value
val = JSONError -> ParserWithErrs a
forall a. JSONError -> ParserWithErrs a
failWith (JSONError -> ParserWithErrs a) -> JSONError -> ParserWithErrs a
forall a b. (a -> b) -> a -> b
$ Expected -> String -> Value -> JSONError
Expected Expected
ExpObject String
"Union" Value
val