{-# language BangPatterns #-}
{-# language BlockArguments #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language KindSignatures #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language OverloadedStrings #-}
module Json.Parser
( Parser(..)
, MemberParser(..)
, run
, key
, keyOptNull
, members
, smallArray
, foldSmallArray
, traverseMembers
, object
, array
, number
, boolean
, string
, int
, int32
, word16
, 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,Word64)
import Json (Value(Object,Array,Number),Member(Member))
import Json.Context (Context(Top,Key,Index))
import Json.Errors (Errors)
import Json.Error (Error(..))
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 -> 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
<$ :: forall a b. a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor
instance Applicative Parser where
pure :: forall a. a -> Parser a
pure a
a = forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
_ -> 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 = forall a. (Context -> Either Errors a) -> Parser a
Parser 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)
instance Alternative Parser where
empty :: forall a. Parser a
empty = forall a. ShortText -> Parser a
fail forall a. Monoid a => a
mempty
Parser a
f <|> :: forall a. Parser a -> Parser a -> Parser a
<|> Parser a
g = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Context
p -> case forall a. Parser a -> Context -> Either Errors a
runParser Parser a
f Context
p of
Right a
x -> forall a b. b -> Either a b
Right a
x
Left Errors
aErrs -> case forall a. Parser a -> Context -> Either Errors a
runParser Parser a
g Context
p of
Right a
y -> forall a b. b -> Either a b
Right a
y
Left Errors
bErrs -> forall a b. a -> Either a b
Left (Errors
aErrs 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 = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Context
p -> do
a
x <- Context -> Either Errors a
f Context
p
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 -> 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
<$ :: forall a b. a -> MemberParser b -> MemberParser a
$c<$ :: forall a b. a -> MemberParser b -> MemberParser a
fmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
$cfmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
Functor
instance Applicative MemberParser where
pure :: forall a. a -> MemberParser a
pure a
a = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser (\Context
_ SmallArray Member
_ -> 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 = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)
instance Alternative MemberParser where
empty :: forall a. MemberParser a
empty = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
_ -> forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton Error{$sel:message:Error :: ShortText
message=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 = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
a Context
p SmallArray Member
mbrs of
Right a
x -> forall a b. b -> Either a b
Right a
x
Left Errors
aErrs -> case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
b Context
p SmallArray Member
mbrs of
Right a
y -> forall a b. b -> Either a b
Right a
y
Left Errors
bErrs -> forall a b. a -> Either a b
Left (Errors
aErrs 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 = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
parser Context
p SmallArray Member
mbrs of
Left Errors
p' -> forall a b. a -> Either a b
Left Errors
p'
Right a
x -> 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 -> forall a b. b -> Either a b
Right a
a
Left Errors
e -> forall a b. a -> Either a b
Left Errors
e
fail :: ShortText -> Parser a
fail :: forall a. ShortText -> Parser a
fail !ShortText
msg = forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
e -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Member
xs
Value
_ -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Value
xs
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 = 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
n
Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number"
string :: Value -> Parser ShortText
string :: Value -> Parser ShortText
string = \case
Json.String ShortText
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
n
Value
_ -> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
Maybe 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
n
Maybe 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
n
Maybe Word16
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^16)"
word64 :: Scientific -> Parser Word64
word64 :: Scientific -> Parser Word64
word64 Scientific
m = case Scientific -> Maybe Word64
SCI.toWord64 Scientific
m of
Just Word64
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
n
Maybe 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Value
Json.False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Value
_ -> 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 = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member{key :: Member -> ShortText
key=ShortText
k} -> ShortText
k forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
Maybe Member
Nothing -> 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: " forall a. Semigroup a => a -> a -> a
<> ShortText
name}))
Just Member{Value
value :: Member -> Value
value :: Value
value} -> 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 = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member{key :: Member -> ShortText
key=ShortText
k} -> ShortText
k forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
Maybe Member
Nothing -> Value
Json.Null
Just Member{Value
value :: Value
value :: Member -> Value
value} -> Value
value
in 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 = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
let !len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Value
xs
SmallMutableArray s a
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len forall a. a
errorThunk
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
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 <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
x) (Int -> Context -> Context
Index Int
ix Context
p)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
dst Int
ix a
y)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
) Int
0 SmallArray Value
xs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray 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 = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
(!Int
_,b
r) <- 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' <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (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)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1, b
acc')
) (Int
0,b
acc0) SmallArray a
xs
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 = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
let !len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Member
xs
SmallMutableArray s a
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len forall a. a
errorThunk
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
!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 <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> Context -> Either Errors a
runParser (Member -> Parser a
f Member
x) (ShortText -> Context -> Context
Key ShortText
k Context
p)))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
dst Int
ix a
y)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
) Int
0 SmallArray Member
xs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
dst)
errorThunk :: a
{-# noinline errorThunk #-}
errorThunk :: forall a. a
errorThunk = 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) = 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'
)