{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Json.Parser
  ( Parser (..)
  , MemberParser (..)

    -- * Run
  , run

    -- * Object Parsing
  , key
  , keyOptNull
  , members

    -- * Arrays
  , smallArray
  , foldSmallArray
  , traverseMembers

    -- * Specific Data Constructors
  , object
  , array
  , number
  , boolean
  , string

    -- * Trivial Combinators
  , int
  , int32
  , word16
  , word32
  , word64

    -- * Failing
  , fail

    -- * Modified Context
  , contextually
  ) where

import Prelude hiding (fail)

import Control.Applicative (Alternative (..))
import Control.Monad.ST (runST)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Data.Foldable (foldlM)
import Data.Int (Int32)
import Data.List (find)
import Data.Number.Scientific (Scientific)
import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Data.Word (Word16, Word32, Word64)
import Json (Member (Member), Value (Array, Number, Object))

-- import Json.Path (Path(Nil,Key,Index))
import Json.Context (Context (Index, Key, Top))
import Json.Error (Error (..))
import Json.Errors (Errors)

import qualified Data.Number.Scientific as SCI
import qualified Data.Primitive as PM
import qualified Json
import qualified Json.Errors as Errors

newtype Parser a = Parser
  {forall a. Parser a -> Context -> Either Errors a
runParser :: Context -> Either Errors a}
  deriving stock ((forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$c<$ :: forall a b. a -> Parser b -> Parser a
<$ :: forall a b. a -> Parser b -> Parser a
Functor)

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
a = (Context -> Either Errors a) -> Parser a
forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
_ -> a -> Either Errors a
forall a b. b -> Either a b
Right a
a)
  Parser Context -> Either Errors (a -> b)
f <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser Context -> Either Errors a
g = (Context -> Either Errors b) -> Parser b
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors b) -> Parser b)
-> (Context -> Either Errors b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Context
p -> do
    a -> b
h <- Context -> Either Errors (a -> b)
f Context
p
    a
y <- Context -> Either Errors a
g Context
p
    b -> Either Errors b
forall a. a -> Either Errors a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)

instance Alternative Parser where
  empty :: forall a. Parser a
empty = ShortText -> Parser a
forall a. ShortText -> Parser a
fail ShortText
forall a. Monoid a => a
mempty
  Parser a
f <|> :: forall a. Parser a -> Parser a -> Parser a
<|> Parser a
g = (Context -> Either Errors a) -> Parser a
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors a) -> Parser a)
-> (Context -> Either Errors a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Context
p -> case Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser Parser a
f Context
p of
    Right a
x -> a -> Either Errors a
forall a b. b -> Either a b
Right a
x
    Left Errors
aErrs -> case Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser Parser a
g Context
p of
      Right a
y -> a -> Either Errors a
forall a b. b -> Either a b
Right a
y
      Left Errors
bErrs -> Errors -> Either Errors a
forall a b. a -> Either a b
Left (Errors
aErrs Errors -> Errors -> Errors
forall a. Semigroup a => a -> a -> a
<> Errors
bErrs)

instance Monad Parser where
  Parser Context -> Either Errors a
f >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
g = (Context -> Either Errors b) -> Parser b
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors b) -> Parser b)
-> (Context -> Either Errors b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Context
p -> do
    a
x <- Context -> Either Errors a
f Context
p
    Parser b -> Context -> Either Errors b
forall a. Parser a -> Context -> Either Errors a
runParser (a -> Parser b
g a
x) Context
p

newtype MemberParser a = MemberParser
  {forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser :: Context -> SmallArray Member -> Either Errors a}
  deriving stock ((forall a b. (a -> b) -> MemberParser a -> MemberParser b)
-> (forall a b. a -> MemberParser b -> MemberParser a)
-> Functor MemberParser
forall a b. a -> MemberParser b -> MemberParser a
forall a b. (a -> b) -> MemberParser a -> MemberParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
fmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
$c<$ :: forall a b. a -> MemberParser b -> MemberParser a
<$ :: forall a b. a -> MemberParser b -> MemberParser a
Functor)

instance Applicative MemberParser where
  pure :: forall a. a -> MemberParser a
pure a
a = (Context -> SmallArray Member -> Either Errors a) -> MemberParser a
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser (\Context
_ SmallArray Member
_ -> a -> Either Errors a
forall a b. b -> Either a b
Right a
a)
  MemberParser Context -> SmallArray Member -> Either Errors (a -> b)
f <*> :: forall a b.
MemberParser (a -> b) -> MemberParser a -> MemberParser b
<*> MemberParser Context -> SmallArray Member -> Either Errors a
g = (Context -> SmallArray Member -> Either Errors b) -> MemberParser b
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors b)
 -> MemberParser b)
-> (Context -> SmallArray Member -> Either Errors b)
-> MemberParser b
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs -> do
    a -> b
h <- Context -> SmallArray Member -> Either Errors (a -> b)
f Context
p SmallArray Member
mbrs
    a
y <- Context -> SmallArray Member -> Either Errors a
g Context
p SmallArray Member
mbrs
    b -> Either Errors b
forall a. a -> Either Errors a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)

instance Alternative MemberParser where
  empty :: forall a. MemberParser a
empty = (Context -> SmallArray Member -> Either Errors a) -> MemberParser a
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors a)
 -> MemberParser a)
-> (Context -> SmallArray Member -> Either Errors a)
-> MemberParser a
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
_ -> Errors -> Either Errors a
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton Error {$sel:message:Error :: ShortText
message = ShortText
forall a. Monoid a => a
mempty, $sel:context:Error :: Context
context = Context
p})
  MemberParser a
a <|> :: forall a. MemberParser a -> MemberParser a -> MemberParser a
<|> MemberParser a
b = (Context -> SmallArray Member -> Either Errors a) -> MemberParser a
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors a)
 -> MemberParser a)
-> (Context -> SmallArray Member -> Either Errors a)
-> MemberParser a
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
    case MemberParser a -> Context -> SmallArray Member -> Either Errors a
forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
a Context
p SmallArray Member
mbrs of
      Right a
x -> a -> Either Errors a
forall a b. b -> Either a b
Right a
x
      Left Errors
aErrs -> case MemberParser a -> Context -> SmallArray Member -> Either Errors a
forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
b Context
p SmallArray Member
mbrs of
        Right a
y -> a -> Either Errors a
forall a b. b -> Either a b
Right a
y
        Left Errors
bErrs -> Errors -> Either Errors a
forall a b. a -> Either a b
Left (Errors
aErrs Errors -> Errors -> Errors
forall a. Semigroup a => a -> a -> a
<> Errors
bErrs)

instance Monad MemberParser where
  MemberParser a
parser >>= :: forall a b.
MemberParser a -> (a -> MemberParser b) -> MemberParser b
>>= a -> MemberParser b
k = (Context -> SmallArray Member -> Either Errors b) -> MemberParser b
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors b)
 -> MemberParser b)
-> (Context -> SmallArray Member -> Either Errors b)
-> MemberParser b
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
    case MemberParser a -> Context -> SmallArray Member -> Either Errors a
forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
parser Context
p SmallArray Member
mbrs of
      Left Errors
p' -> Errors -> Either Errors b
forall a b. a -> Either a b
Left Errors
p'
      Right a
x -> MemberParser b -> Context -> SmallArray Member -> Either Errors b
forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser (a -> MemberParser b
k a
x) Context
p SmallArray Member
mbrs

run :: Parser a -> Either Errors a
run :: forall a. Parser a -> Either Errors a
run (Parser Context -> Either Errors a
f) = case Context -> Either Errors a
f Context
Top of
  Right a
a -> a -> Either Errors a
forall a b. b -> Either a b
Right a
a
  Left Errors
e -> Errors -> Either Errors a
forall a b. a -> Either a b
Left Errors
e

fail :: ShortText -> Parser a
fail :: forall a. ShortText -> Parser a
fail !ShortText
msg = (Context -> Either Errors a) -> Parser a
forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
e -> Errors -> Either Errors a
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton Error {$sel:context:Error :: Context
context = Context
e, $sel:message:Error :: ShortText
message = ShortText
msg}))

object :: Value -> Parser (SmallArray Member)
object :: Value -> Parser (SmallArray Member)
object = \case
  Object SmallArray Member
xs -> SmallArray Member -> Parser (SmallArray Member)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Member
xs
  Value
_ -> ShortText -> Parser (SmallArray Member)
forall a. ShortText -> Parser a
fail ShortText
"expected object"

array :: Value -> Parser (SmallArray Value)
array :: Value -> Parser (SmallArray Value)
array = \case
  Array SmallArray Value
xs -> SmallArray Value -> Parser (SmallArray Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Value
xs
  Value
_ -> ShortText -> Parser (SmallArray Value)
forall a. ShortText -> Parser a
fail ShortText
"expected array"

members :: MemberParser a -> SmallArray Member -> Parser a
members :: forall a. MemberParser a -> SmallArray Member -> Parser a
members (MemberParser Context -> SmallArray Member -> Either Errors a
f) SmallArray Member
mbrs = (Context -> Either Errors a) -> Parser a
forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
p -> Context -> SmallArray Member -> Either Errors a
f Context
p SmallArray Member
mbrs)

number :: Value -> Parser Scientific
number :: Value -> Parser Scientific
number = \case
  Number Scientific
n -> Scientific -> Parser Scientific
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
n
  Value
_ -> ShortText -> Parser Scientific
forall a. ShortText -> Parser a
fail ShortText
"expected number"

string :: Value -> Parser ShortText
string :: Value -> Parser ShortText
string = \case
  Json.String ShortText
n -> ShortText -> Parser ShortText
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
n
  Value
_ -> ShortText -> Parser ShortText
forall a. ShortText -> Parser a
fail ShortText
"expected string"

int :: Scientific -> Parser Int
int :: Scientific -> Parser Int
int Scientific
m = case Scientific -> Maybe Int
SCI.toInt Scientific
m of
  Just Int
n -> Int -> Parser Int
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
  Maybe Int
_ -> ShortText -> Parser Int
forall a. ShortText -> Parser a
fail ShortText
"expected number in signed machine integer range"

int32 :: Scientific -> Parser Int32
int32 :: Scientific -> Parser Int32
int32 Scientific
m = case Scientific -> Maybe Int32
SCI.toInt32 Scientific
m of
  Just Int32
n -> Int32 -> Parser Int32
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
n
  Maybe Int32
_ -> ShortText -> Parser Int32
forall a. ShortText -> Parser a
fail ShortText
"expected number in range [-2^31,2^31-1)"

word16 :: Scientific -> Parser Word16
word16 :: Scientific -> Parser Word16
word16 Scientific
m = case Scientific -> Maybe Word16
SCI.toWord16 Scientific
m of
  Just Word16
n -> Word16 -> Parser Word16
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
n
  Maybe Word16
_ -> ShortText -> Parser Word16
forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^16)"

word32 :: Scientific -> Parser Word32
word32 :: Scientific -> Parser Word32
word32 Scientific
m = case Scientific -> Maybe Word32
SCI.toWord32 Scientific
m of
  Just Word32
n -> Word32 -> Parser Word32
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
n
  Maybe Word32
_ -> ShortText -> Parser Word32
forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^32)"

word64 :: Scientific -> Parser Word64
word64 :: Scientific -> Parser Word64
word64 Scientific
m = case Scientific -> Maybe Word64
SCI.toWord64 Scientific
m of
  Just Word64
n -> Word64 -> Parser Word64
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
n
  Maybe Word64
_ -> ShortText -> Parser Word64
forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^64)"

boolean :: Value -> Parser Bool
boolean :: Value -> Parser Bool
boolean = \case
  Value
Json.True -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Value
Json.False -> Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Value
_ -> ShortText -> Parser Bool
forall a. ShortText -> Parser a
fail ShortText
"expected boolean"

-- members :: Parser Value (Chunks Member)
-- members = _

key :: ShortText -> (Value -> Parser a) -> MemberParser a
key :: forall a. ShortText -> (Value -> Parser a) -> MemberParser a
key !ShortText
name Value -> Parser a
f = (Context -> SmallArray Member -> Either Errors a) -> MemberParser a
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors a)
 -> MemberParser a)
-> (Context -> SmallArray Member -> Either Errors a)
-> MemberParser a
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
  let !p' :: Context
p' = ShortText -> Context -> Context
Key ShortText
name Context
p
   in case (Member -> Bool) -> SmallArray Member -> Maybe Member
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member {key :: Member -> ShortText
key = ShortText
k} -> ShortText
k ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
        Maybe Member
Nothing -> Errors -> Either Errors a
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (Error {$sel:context:Error :: Context
context = Context
p', $sel:message:Error :: ShortText
message = ShortText
"key not found: " ShortText -> ShortText -> ShortText
forall a. Semigroup a => a -> a -> a
<> ShortText
name}))
        Just Member {Value
value :: Value
value :: Member -> Value
value} -> Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
value) Context
p'

{- | Variant of 'key' that supplies the JSON value @null@ to the
callback if the key is not found. Using this parser combinators implies
that there is no distinction between @null@ and an absent value in
the encoding scheme.
-}
keyOptNull :: ShortText -> (Value -> Parser a) -> MemberParser a
keyOptNull :: forall a. ShortText -> (Value -> Parser a) -> MemberParser a
keyOptNull !ShortText
name Value -> Parser a
f = (Context -> SmallArray Member -> Either Errors a) -> MemberParser a
forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser ((Context -> SmallArray Member -> Either Errors a)
 -> MemberParser a)
-> (Context -> SmallArray Member -> Either Errors a)
-> MemberParser a
forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
  let !p' :: Context
p' = ShortText -> Context -> Context
Key ShortText
name Context
p
      val :: Value
val = case (Member -> Bool) -> SmallArray Member -> Maybe Member
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member {key :: Member -> ShortText
key = ShortText
k} -> ShortText
k ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
        Maybe Member
Nothing -> Value
Json.Null
        Just Member {Value
value :: Member -> Value
value :: Value
value} -> Value
value
   in Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
val) Context
p'

-- object2 ::
--      (a -> b -> c)
--   -> ShortText -> Parser a
--   -> ShortText -> Parser b
--   -> Parser c
-- object2 f ka pa kb pb = Parser $ \p v -> case v

-- elements :: Parser Value (Chunks Value)
-- elements = _

{- | Run the same parser against every element in a 'SmallArray'. This adjusts
the context at each element.
-}
smallArray :: (Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a)
smallArray :: forall a.
(Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a)
smallArray Value -> Parser a
f SmallArray Value
xs = (Context -> Either Errors (SmallArray a)) -> Parser (SmallArray a)
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors (SmallArray a))
 -> Parser (SmallArray a))
-> (Context -> Either Errors (SmallArray a))
-> Parser (SmallArray a)
forall a b. (a -> b) -> a -> b
$ \ !Context
p -> (forall s. ST s (Either Errors (SmallArray a)))
-> Either Errors (SmallArray a)
forall a. (forall s. ST s a) -> a
runST do
  let !len :: Int
len = SmallArray Value -> Int
forall a. SmallArray a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Value
xs
  SmallMutableArray s a
dst <- Int -> a -> ST s (SmallMutableArray (PrimState (ST s)) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len a
forall a. a
errorThunk
  ExceptT Errors (ST s) (SmallArray a)
-> ST s (Either Errors (SmallArray a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Errors (ST s) (SmallArray a)
 -> ST s (Either Errors (SmallArray a)))
-> ExceptT Errors (ST s) (SmallArray a)
-> ST s (Either Errors (SmallArray a))
forall a b. (a -> b) -> a -> b
$ do
    Int
_ <-
      (Int -> Value -> ExceptT Errors (ST s) Int)
-> Int -> SmallArray Value -> ExceptT Errors (ST s) Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
        ( \Int
ix Value
x -> do
            !a
y <- ST s (Either Errors a) -> ExceptT Errors (ST s) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Errors a -> ST s (Either Errors a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
x) (Int -> Context -> Context
Index Int
ix Context
p)))
            ST s () -> ExceptT Errors (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Errors m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst Int
ix a
y)
            Int -> ExceptT Errors (ST s) Int
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        )
        Int
0
        SmallArray Value
xs
    ST s (SmallArray a) -> ExceptT Errors (ST s) (SmallArray a)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Errors m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> ST s (SmallArray a)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst)

{- | Run the parser against every element in a 'SmallArray', updating an
accumulator at each step. Folds from left to right. This adjusts
the context at each element. Typically, type @a@ is @Value@.
-}
foldSmallArray :: (b -> a -> Parser b) -> b -> SmallArray a -> Parser b
{-# INLINE foldSmallArray #-}
foldSmallArray :: forall b a. (b -> a -> Parser b) -> b -> SmallArray a -> Parser b
foldSmallArray b -> a -> Parser b
f b
acc0 SmallArray a
xs = (Context -> Either Errors b) -> Parser b
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors b) -> Parser b)
-> (Context -> Either Errors b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \ !Context
p -> (forall s. ST s (Either Errors b)) -> Either Errors b
forall a. (forall s. ST s a) -> a
runST do
  -- TODO: make sure tuples get elided
  ExceptT Errors (ST s) b -> ST s (Either Errors b)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Errors (ST s) b -> ST s (Either Errors b))
-> ExceptT Errors (ST s) b -> ST s (Either Errors b)
forall a b. (a -> b) -> a -> b
$ do
    (!Int
_, b
r) <-
      ((Int, b) -> a -> ExceptT Errors (ST s) (Int, b))
-> (Int, b) -> SmallArray a -> ExceptT Errors (ST s) (Int, b)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
        ( \(!Int
ix, !b
acc) a
x -> do
            !b
acc' <- ST s (Either Errors b) -> ExceptT Errors (ST s) b
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Errors b -> ST s (Either Errors b)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser b -> Context -> Either Errors b
forall a. Parser a -> Context -> Either Errors a
runParser (b -> a -> Parser b
f b
acc a
x) (Int -> Context -> Context
Index Int
ix Context
p)))
            (Int, b) -> ExceptT Errors (ST s) (Int, b)
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, b
acc')
        )
        (Int
0, b
acc0)
        SmallArray a
xs
    b -> ExceptT Errors (ST s) b
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

-- | Traverse the members. The adjusts the context at each member.
traverseMembers :: (Member -> Parser a) -> SmallArray Member -> Parser (SmallArray a)
traverseMembers :: forall a.
(Member -> Parser a) -> SmallArray Member -> Parser (SmallArray a)
traverseMembers Member -> Parser a
f !SmallArray Member
xs = (Context -> Either Errors (SmallArray a)) -> Parser (SmallArray a)
forall a. (Context -> Either Errors a) -> Parser a
Parser ((Context -> Either Errors (SmallArray a))
 -> Parser (SmallArray a))
-> (Context -> Either Errors (SmallArray a))
-> Parser (SmallArray a)
forall a b. (a -> b) -> a -> b
$ \ !Context
p -> (forall s. ST s (Either Errors (SmallArray a)))
-> Either Errors (SmallArray a)
forall a. (forall s. ST s a) -> a
runST do
  let !len :: Int
len = SmallArray Member -> Int
forall a. SmallArray a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Member
xs
  SmallMutableArray s a
dst <- Int -> a -> ST s (SmallMutableArray (PrimState (ST s)) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len a
forall a. a
errorThunk
  ExceptT Errors (ST s) (SmallArray a)
-> ST s (Either Errors (SmallArray a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Errors (ST s) (SmallArray a)
 -> ST s (Either Errors (SmallArray a)))
-> ExceptT Errors (ST s) (SmallArray a)
-> ST s (Either Errors (SmallArray a))
forall a b. (a -> b) -> a -> b
$ do
    !Int
_ <-
      (Int -> Member -> ExceptT Errors (ST s) Int)
-> Int -> SmallArray Member -> ExceptT Errors (ST s) Int
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
        ( \ !Int
ix x :: Member
x@Member {key :: Member -> ShortText
key = ShortText
k} -> do
            !a
y <- ST s (Either Errors a) -> ExceptT Errors (ST s) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Errors a -> ST s (Either Errors a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser a -> Context -> Either Errors a
forall a. Parser a -> Context -> Either Errors a
runParser (Member -> Parser a
f Member
x) (ShortText -> Context -> Context
Key ShortText
k Context
p)))
            ST s () -> ExceptT Errors (ST s) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT Errors m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst Int
ix a
y)
            Int -> ExceptT Errors (ST s) Int
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        )
        Int
0
        SmallArray Member
xs
    ST s (SmallArray a) -> ExceptT Errors (ST s) (SmallArray a)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Errors m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> ST s (SmallArray a)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst)

errorThunk :: a
{-# NOINLINE errorThunk #-}
errorThunk :: forall a. a
errorThunk = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"Json.Parser: implementation mistake"

-- | Run a parser in a modified context.
contextually :: (Context -> Context) -> Parser a -> Parser a
{-# INLINE contextually #-}
contextually :: forall a. (Context -> Context) -> Parser a -> Parser a
contextually Context -> Context
f (Parser Context -> Either Errors a
g) =
  (Context -> Either Errors a) -> Parser a
forall a. (Context -> Either Errors a) -> Parser a
Parser
    ( \Context
p ->
        let !p' :: Context
p' = Context -> Context
f Context
p
         in Context -> Either Errors a
g Context
p'
    )