{-# 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
, key
, keyOptNull
, members
, smallArray
, foldSmallArray
, traverseMembers
, object
, array
, number
, boolean
, string
, int
, int32
, word16
, word32
, word64
, fail
, 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.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"
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'
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'
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)
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
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
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"
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'
)