{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Json.Arrow
( Parser
, type (~>)
, run
, object
, array
, string
, strings
, number
, boolean
, null
, Members (..)
, member
, memberOpt
, foldMembers
, Elements
, foldl'
, map
, fail
, failZero
, withObject
, withArray
, fromNull
, int
, word16
, word64
, liftMaybe
) where
import Prelude hiding (fail, id, map, null, (.))
import Control.Arrow (Arrow (..), ArrowApply (..), ArrowChoice (..), ArrowPlus (..), ArrowZero (..), (>>>))
import Control.Category (Category (..))
import Control.Monad.ST (runST)
import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT)
import Data.List (find)
import Data.Number.Scientific (Scientific)
import Data.Primitive (SmallArray)
import Data.Primitive.Unlifted.Array (UnliftedArray)
import Data.Profunctor (Profunctor (..))
import Data.Text.Short (ShortText)
import Data.Word (Word16, Word64)
import Json (Member (Member), Value (Array, Number, Object, String))
import Json.Context (Context (..))
import Json.Error (Error (..))
import Json.Errors (Errors)
import qualified Data.Number.Scientific as SCI
import qualified Data.Primitive.Contiguous as Arr
import qualified Json
import qualified Json.Errors as Errors
newtype Parser a b = P
{ forall a b.
Parser a b -> Context -> a -> Either Errors (Context, b)
unParser ::
Context ->
a ->
Either Errors (Context, b)
}
type a ~> b = Parser a b
run :: (a ~> b) -> a -> Either Errors b
run :: forall a b. (a ~> b) -> a -> Either Errors b
run (P Context -> a -> Either Errors (Context, b)
p) a
x = (Context, b) -> b
forall a b. (a, b) -> b
snd ((Context, b) -> b)
-> Either Errors (Context, b) -> Either Errors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> a -> Either Errors (Context, b)
p Context
Top a
x
object :: Value ~> Members
object :: Value ~> Members
object = (Context -> Value -> Either Errors (Context, Members))
-> Value ~> Members
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, Members))
-> Value ~> Members)
-> (Context -> Value -> Either Errors (Context, Members))
-> Value ~> Members
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Object SmallArray Member
membs -> (Context, Members) -> Either Errors (Context, Members)
forall a b. b -> Either a b
Right (Context
ctx, SmallArray Member -> Members
Members SmallArray Member
membs)
Value
_ -> Errors -> Either Errors (Context, Members)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected object" Context
ctx))
array :: Value ~> Elements
array :: Value ~> Elements
array = (Context -> Value -> Either Errors (Context, Elements))
-> Value ~> Elements
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, Elements))
-> Value ~> Elements)
-> (Context -> Value -> Either Errors (Context, Elements))
-> Value ~> Elements
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Array SmallArray Value
membs -> (Context, Elements) -> Either Errors (Context, Elements)
forall a b. b -> Either a b
Right (Context
ctx, SmallArray Value -> Elements
Elements SmallArray Value
membs)
Value
_ -> Errors -> Either Errors (Context, Elements)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected array" Context
ctx))
string :: Value ~> ShortText
string :: Value ~> ShortText
string = (Context -> Value -> Either Errors (Context, ShortText))
-> Value ~> ShortText
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, ShortText))
-> Value ~> ShortText)
-> (Context -> Value -> Either Errors (Context, ShortText))
-> Value ~> ShortText
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
String ShortText
str -> (Context, ShortText) -> Either Errors (Context, ShortText)
forall a b. b -> Either a b
Right (Context
ctx, ShortText
str)
Value
_ -> Errors -> Either Errors (Context, ShortText)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected string" Context
ctx))
strings :: Value ~> UnliftedArray ShortText
strings :: Value ~> UnliftedArray ShortText
strings = (Context
-> Value -> Either Errors (Context, UnliftedArray ShortText))
-> Value ~> UnliftedArray ShortText
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context
-> Value -> Either Errors (Context, UnliftedArray ShortText))
-> Value ~> UnliftedArray ShortText)
-> (Context
-> Value -> Either Errors (Context, UnliftedArray ShortText))
-> Value ~> UnliftedArray ShortText
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Array SmallArray Value
membs -> (forall s. ST s (Either Errors (Context, UnliftedArray ShortText)))
-> Either Errors (Context, UnliftedArray ShortText)
forall a. (forall s. ST s a) -> a
runST ((forall s.
ST s (Either Errors (Context, UnliftedArray ShortText)))
-> Either Errors (Context, UnliftedArray ShortText))
-> (forall s.
ST s (Either Errors (Context, UnliftedArray ShortText)))
-> Either Errors (Context, UnliftedArray ShortText)
forall a b. (a -> b) -> a -> b
$ ExceptT Errors (ST s) (Context, UnliftedArray ShortText)
-> ST s (Either Errors (Context, UnliftedArray ShortText))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Errors (ST s) (Context, UnliftedArray ShortText)
-> ST s (Either Errors (Context, UnliftedArray ShortText)))
-> ExceptT Errors (ST s) (Context, UnliftedArray ShortText)
-> ST s (Either Errors (Context, UnliftedArray ShortText))
forall a b. (a -> b) -> a -> b
$ do
UnliftedArray_ ByteArray# ShortText
xs <-
(Int -> Value -> ExceptT Errors (ST s) ShortText)
-> SmallArray Value
-> ExceptT Errors (ST s) (UnliftedArray_ ByteArray# ShortText)
forall (m :: * -> *) (arr1 :: * -> *) a (arr2 :: * -> *) b.
(PrimMonad m, Contiguous arr1, Element arr1 a, Contiguous arr2,
Element arr2 b) =>
(Int -> a -> m b) -> arr1 a -> m (arr2 b)
Arr.itraverseP
( \Int
ix Value
e -> case Value
e of
String ShortText
s -> ShortText -> ExceptT Errors (ST s) ShortText
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
s
Value
_ -> ST s (Either Errors ShortText) -> ExceptT Errors (ST s) ShortText
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Errors ShortText -> ST s (Either Errors ShortText)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Errors -> Either Errors ShortText
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected string" (Int -> Context -> Context
Index Int
ix Context
ctx)))))
)
SmallArray Value
membs
(Context, UnliftedArray_ ByteArray# ShortText)
-> ExceptT
Errors (ST s) (Context, UnliftedArray_ ByteArray# ShortText)
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context
ctx, UnliftedArray_ ByteArray# ShortText
xs)
Value
_ -> Errors
-> Either Errors (Context, UnliftedArray_ ByteArray# ShortText)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected array" Context
ctx))
number :: Value ~> Scientific
number :: Value ~> Scientific
number = (Context -> Value -> Either Errors (Context, Scientific))
-> Value ~> Scientific
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, Scientific))
-> Value ~> Scientific)
-> (Context -> Value -> Either Errors (Context, Scientific))
-> Value ~> Scientific
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Number Scientific
n -> (Context, Scientific) -> Either Errors (Context, Scientific)
forall a b. b -> Either a b
Right (Context
ctx, Scientific
n)
Value
_ -> Errors -> Either Errors (Context, Scientific)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected number" Context
ctx))
boolean :: Value ~> Bool
boolean :: Value ~> Bool
boolean = (Context -> Value -> Either Errors (Context, Bool))
-> Value ~> Bool
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, Bool))
-> Value ~> Bool)
-> (Context -> Value -> Either Errors (Context, Bool))
-> Value ~> Bool
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Value
Json.True -> (Context, Bool) -> Either Errors (Context, Bool)
forall a b. b -> Either a b
Right (Context
ctx, Bool
True)
Value
Json.False -> (Context, Bool) -> Either Errors (Context, Bool)
forall a b. b -> Either a b
Right (Context
ctx, Bool
False)
Value
_ -> Errors -> Either Errors (Context, Bool)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected boolean" Context
ctx))
null :: Value ~> ()
null :: Value ~> ()
null = (Context -> Value -> Either Errors (Context, ())) -> Value ~> ()
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, ())) -> Value ~> ())
-> (Context -> Value -> Either Errors (Context, ())) -> Value ~> ()
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
Value
Json.Null -> (Context, ()) -> Either Errors (Context, ())
forall a b. b -> Either a b
Right (Context
ctx, ())
Value
_ -> Errors -> Either Errors (Context, ())
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"expected null" Context
ctx))
newtype Members = Members {Members -> SmallArray Member
unMembers :: SmallArray Member}
member :: ShortText -> Members ~> Value
member :: ShortText -> Members ~> Value
member ShortText
k = (Context -> Members -> Either Errors (Context, Value))
-> Members ~> Value
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Members -> Either Errors (Context, Value))
-> Members ~> Value)
-> (Context -> Members -> Either Errors (Context, Value))
-> Members ~> Value
forall a b. (a -> b) -> a -> b
$ \Context
ctx Members
xs -> case (Member -> Bool) -> SmallArray Member -> Maybe Member
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Member -> Bool
keyEq (Members -> SmallArray Member
unMembers Members
xs) of
Just Member {Value
value :: Value
value :: Member -> Value
value} -> (Context, Value) -> Either Errors (Context, Value)
forall a b. b -> Either a b
Right (ShortText -> Context -> Context
Key ShortText
k Context
ctx, Value
value)
Maybe Member
Nothing -> Errors -> Either Errors (Context, Value)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error (ShortText
"key not found: " ShortText -> ShortText -> ShortText
forall a. Semigroup a => a -> a -> a
<> ShortText
k) Context
ctx))
where
keyEq :: Member -> Bool
keyEq Member {ShortText
key :: ShortText
key :: Member -> ShortText
key} = ShortText
k ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
key
memberOpt :: ShortText -> Members ~> Maybe Value
memberOpt :: ShortText -> Members ~> Maybe Value
memberOpt ShortText
k = (Context -> Members -> Either Errors (Context, Maybe Value))
-> Members ~> Maybe Value
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Members -> Either Errors (Context, Maybe Value))
-> Members ~> Maybe Value)
-> (Context -> Members -> Either Errors (Context, Maybe Value))
-> Members ~> Maybe Value
forall a b. (a -> b) -> a -> b
$ \Context
ctx Members
xs -> case (Member -> Bool) -> SmallArray Member -> Maybe Member
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Member -> Bool
keyEq (Members -> SmallArray Member
unMembers Members
xs) of
Just Member {Value
value :: Member -> Value
value :: Value
value} -> (Context, Maybe Value) -> Either Errors (Context, Maybe Value)
forall a b. b -> Either a b
Right (ShortText -> Context -> Context
Key ShortText
k Context
ctx, Value -> Maybe Value
forall a. a -> Maybe a
Just Value
value)
Maybe Member
Nothing -> (Context, Maybe Value) -> Either Errors (Context, Maybe Value)
forall a b. b -> Either a b
Right (Context
ctx, Maybe Value
forall a. Maybe a
Nothing)
where
keyEq :: Member -> Bool
keyEq Member {ShortText
key :: Member -> ShortText
key :: ShortText
key} = ShortText
k ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
key
foldMembers :: a -> (a -> Member ~> a) -> Members ~> a
foldMembers :: forall a. a -> (a -> Member ~> a) -> Members ~> a
foldMembers a
z0 a -> Member ~> a
f = (Context -> Members -> Either Errors (Context, a))
-> Parser Members a
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Members -> Either Errors (Context, a))
-> Parser Members a)
-> (Context -> Members -> Either Errors (Context, a))
-> Parser Members a
forall a b. (a -> b) -> a -> b
$ \Context
ctx Members
membs ->
let xs :: SmallArray Member
xs = Members -> SmallArray Member
unMembers Members
membs
loop :: a -> Int -> Either Errors (Context, a)
loop !a
z !Int
i =
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SmallArray Member -> Int
forall b. Element SmallArray b => SmallArray b -> Int
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int
Arr.size SmallArray Member
xs
then
let x :: Member
x@Member {ShortText
key :: Member -> ShortText
key :: ShortText
key} = SmallArray Member -> Int -> Member
forall b. Element SmallArray b => SmallArray b -> Int -> b
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b
Arr.index SmallArray Member
xs Int
i
in case (Member ~> a) -> Context -> Member -> Either Errors (Context, a)
forall a b.
Parser a b -> Context -> a -> Either Errors (Context, b)
unParser (a -> Member ~> a
f a
z) (ShortText -> Context -> Context
Key ShortText
key Context
ctx) Member
x of
Right (Context
_, a
z') -> a -> Int -> Either Errors (Context, a)
loop a
z' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Left Errors
err -> Errors -> Either Errors (Context, a)
forall a b. a -> Either a b
Left Errors
err
else (Context, a) -> Either Errors (Context, a)
forall a b. b -> Either a b
Right (Context
ctx, a
z)
in a -> Int -> Either Errors (Context, a)
loop a
z0 Int
0
newtype Elements = Elements {Elements -> SmallArray Value
unElements :: SmallArray Value}
foldl' :: a -> (a -> Value ~> a) -> Elements ~> a
foldl' :: forall a. a -> (a -> Value ~> a) -> Elements ~> a
foldl' a
z0 a -> Value ~> a
f = (Context -> Elements -> Either Errors (Context, a))
-> Parser Elements a
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Elements -> Either Errors (Context, a))
-> Parser Elements a)
-> (Context -> Elements -> Either Errors (Context, a))
-> Parser Elements a
forall a b. (a -> b) -> a -> b
$ \Context
ctx Elements
elems ->
let xs :: SmallArray Value
xs = Elements -> SmallArray Value
unElements Elements
elems
loop :: a -> Int -> Either Errors (Context, a)
loop !a
z !Int
i =
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< SmallArray Value -> Int
forall b. Element SmallArray b => SmallArray b -> Int
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int
Arr.size SmallArray Value
xs
then case (Value ~> a) -> Context -> Value -> Either Errors (Context, a)
forall a b.
Parser a b -> Context -> a -> Either Errors (Context, b)
unParser (a -> Value ~> a
f a
z) (Int -> Context -> Context
Index Int
i Context
ctx) (SmallArray Value -> Int -> Value
forall b. Element SmallArray b => SmallArray b -> Int -> b
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b
Arr.index SmallArray Value
xs Int
i) of
Right (Context
_, a
z') -> a -> Int -> Either Errors (Context, a)
loop a
z' (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Left Errors
err -> Errors -> Either Errors (Context, a)
forall a b. a -> Either a b
Left Errors
err
else (Context, a) -> Either Errors (Context, a)
forall a b. b -> Either a b
Right (Context
ctx, a
z)
in a -> Int -> Either Errors (Context, a)
loop a
z0 Int
0
map :: (Value ~> a) -> Elements ~> SmallArray a
map :: forall a. (Value ~> a) -> Elements ~> SmallArray a
map (P Context -> Value -> Either Errors (Context, a)
p) = (Context -> Elements -> Either Errors (Context, SmallArray a))
-> Parser Elements (SmallArray a)
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Elements -> Either Errors (Context, SmallArray a))
-> Parser Elements (SmallArray a))
-> (Context -> Elements -> Either Errors (Context, SmallArray a))
-> Parser Elements (SmallArray a)
forall a b. (a -> b) -> a -> b
$ \Context
ctx (Elements SmallArray Value
xs) -> (forall s. ST s (Either Errors (Context, SmallArray a)))
-> Either Errors (Context, SmallArray a)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either Errors (Context, SmallArray a)))
-> Either Errors (Context, SmallArray a))
-> (forall s. ST s (Either Errors (Context, SmallArray a)))
-> Either Errors (Context, SmallArray a)
forall a b. (a -> b) -> a -> b
$ 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
Mutable SmallArray (PrimState (ST s)) a
dst <- Int -> ST s (Mutable SmallArray (PrimState (ST s)) a)
forall (arr :: * -> *) (m :: * -> *) b.
(Contiguous arr, PrimMonad m, Element arr b) =>
Int -> m (Mutable arr (PrimState m) b)
forall (m :: * -> *) b.
(PrimMonad m, Element SmallArray b) =>
Int -> m (Mutable SmallArray (PrimState m) b)
Arr.new Int
len
let loop :: Int -> ST s (Either Errors ())
loop !Int
i =
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
len
then case Context -> Value -> Either Errors (Context, a)
p (Int -> Context -> Context
Index Int
i Context
ctx) (SmallArray Value -> Int -> Value
forall b. Element SmallArray b => SmallArray b -> Int -> b
forall (arr :: * -> *) b.
(Contiguous arr, Element arr b) =>
arr b -> Int -> b
Arr.index SmallArray Value
xs Int
i) of
Right (Context
_, a
y) -> do
Mutable SmallArray (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (arr :: * -> *) (m :: * -> *) b.
(Contiguous arr, PrimMonad m, Element arr b) =>
Mutable arr (PrimState m) b -> Int -> b -> m ()
forall (m :: * -> *) b.
(PrimMonad m, Element SmallArray b) =>
Mutable SmallArray (PrimState m) b -> Int -> b -> m ()
Arr.write Mutable SmallArray (PrimState (ST s)) a
dst Int
i a
y
Int -> ST s (Either Errors ())
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Left Errors
err -> Either Errors () -> ST s (Either Errors ())
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors () -> ST s (Either Errors ()))
-> Either Errors () -> ST s (Either Errors ())
forall a b. (a -> b) -> a -> b
$ Errors -> Either Errors ()
forall a b. a -> Either a b
Left Errors
err
else Either Errors () -> ST s (Either Errors ())
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors () -> ST s (Either Errors ()))
-> Either Errors () -> ST s (Either Errors ())
forall a b. (a -> b) -> a -> b
$ () -> Either Errors ()
forall a b. b -> Either a b
Right ()
Int -> ST s (Either Errors ())
loop Int
0 ST s (Either Errors ())
-> (Either Errors ()
-> ST s (Either Errors (Context, SmallArray a)))
-> ST s (Either Errors (Context, SmallArray a))
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right ()
_ -> do
SmallArray a
ys <- Mutable SmallArray (PrimState (ST s)) a -> ST s (SmallArray a)
forall (arr :: * -> *) (m :: * -> *) b.
(Contiguous arr, PrimMonad m, Element arr b) =>
Mutable arr (PrimState m) b -> m (arr b)
forall (m :: * -> *) b.
(PrimMonad m, Element SmallArray b) =>
Mutable SmallArray (PrimState m) b -> m (SmallArray b)
Arr.unsafeFreeze Mutable SmallArray (PrimState (ST s)) a
dst
Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a))
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a)))
-> Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a))
forall a b. (a -> b) -> a -> b
$ (Context, SmallArray a) -> Either Errors (Context, SmallArray a)
forall a b. b -> Either a b
Right (Context
ctx, SmallArray a
ys)
Left Errors
err -> Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a))
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a)))
-> Either Errors (Context, SmallArray a)
-> ST s (Either Errors (Context, SmallArray a))
forall a b. (a -> b) -> a -> b
$ Errors -> Either Errors (Context, SmallArray a)
forall a b. a -> Either a b
Left Errors
err
instance Functor (Parser a) where
fmap :: forall a b. (a -> b) -> Parser a a -> Parser a b
fmap a -> b
f (P Context -> a -> Either Errors (Context, a)
p) = (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, b)) -> Parser a b)
-> (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> case Context -> a -> Either Errors (Context, a)
p Context
ctx a
x of
Right (Context
ctx', a
y) -> (Context, b) -> Either Errors (Context, b)
forall a b. b -> Either a b
Right (Context
ctx', a -> b
f a
y)
Left Errors
err -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left Errors
err
instance Profunctor Parser where
dimap :: forall a b c d. (a -> b) -> (c -> d) -> Parser b c -> Parser a d
dimap a -> b
g c -> d
f (P Context -> b -> Either Errors (Context, c)
p) = (Context -> a -> Either Errors (Context, d)) -> Parser a d
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, d)) -> Parser a d)
-> (Context -> a -> Either Errors (Context, d)) -> Parser a d
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> case Context -> b -> Either Errors (Context, c)
p Context
ctx (a -> b
g a
x) of
Right (Context
ctx', c
y) -> (Context, d) -> Either Errors (Context, d)
forall a b. b -> Either a b
Right (Context
ctx', c -> d
f c
y)
Left Errors
err -> Errors -> Either Errors (Context, d)
forall a b. a -> Either a b
Left Errors
err
instance Applicative (Parser a) where
pure :: forall a. a -> Parser a a
pure a
x = (Context -> a -> Either Errors (Context, a)) -> Parser a a
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, a)) -> Parser a a)
-> (Context -> a -> Either Errors (Context, a)) -> Parser a a
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
_ -> (Context, a) -> Either Errors (Context, a)
forall a b. b -> Either a b
Right (Context
ctx, a
x)
(P Context -> a -> Either Errors (Context, a -> b)
p) <*> :: forall a b. Parser a (a -> b) -> Parser a a -> Parser a b
<*> (P Context -> a -> Either Errors (Context, a)
q) = (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, b)) -> Parser a b)
-> (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> case (Context -> a -> Either Errors (Context, a -> b)
p Context
ctx a
x, Context -> a -> Either Errors (Context, a)
q Context
ctx a
x) of
(Right (Context
_, a -> b
f), Right (Context
_, a
y)) -> (Context, b) -> Either Errors (Context, b)
forall a b. b -> Either a b
Right (Context
ctx, a -> b
f a
y)
(Left Errors
err, Either Errors (Context, a)
_) -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left Errors
err
(Either Errors (Context, a -> b)
_, Left Errors
err) -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left Errors
err
instance Category Parser where
id :: forall a. Parser a a
id = (Context -> a -> Either Errors (Context, a)) -> Parser a a
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, a)) -> Parser a a)
-> (Context -> a -> Either Errors (Context, a)) -> Parser a a
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> (Context, a) -> Either Errors (Context, a)
forall a b. b -> Either a b
Right (Context
ctx, a
x)
(P Context -> b -> Either Errors (Context, c)
q) . :: forall b c a. Parser b c -> Parser a b -> Parser a c
. (P Context -> a -> Either Errors (Context, b)
p) = (Context -> a -> Either Errors (Context, c)) -> Parser a c
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, c)) -> Parser a c)
-> (Context -> a -> Either Errors (Context, c)) -> Parser a c
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> case Context -> a -> Either Errors (Context, b)
p Context
ctx a
x of
Right (Context
ctx', b
y) -> Context -> b -> Either Errors (Context, c)
q Context
ctx' b
y
Left Errors
err -> Errors -> Either Errors (Context, c)
forall a b. a -> Either a b
Left Errors
err
instance Arrow Parser where
arr :: forall b c. (b -> c) -> Parser b c
arr b -> c
f = (Context -> b -> Either Errors (Context, c)) -> Parser b c
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> b -> Either Errors (Context, c)) -> Parser b c)
-> (Context -> b -> Either Errors (Context, c)) -> Parser b c
forall a b. (a -> b) -> a -> b
$ \Context
ctx b
x -> (Context, c) -> Either Errors (Context, c)
forall a b. b -> Either a b
Right (Context
ctx, b -> c
f b
x)
(P Context -> b -> Either Errors (Context, c)
p) *** :: forall b c b' c'.
Parser b c -> Parser b' c' -> Parser (b, b') (c, c')
*** (P Context -> b' -> Either Errors (Context, c')
q) = (Context -> (b, b') -> Either Errors (Context, (c, c')))
-> Parser (b, b') (c, c')
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> (b, b') -> Either Errors (Context, (c, c')))
-> Parser (b, b') (c, c'))
-> (Context -> (b, b') -> Either Errors (Context, (c, c')))
-> Parser (b, b') (c, c')
forall a b. (a -> b) -> a -> b
$ \Context
ctx (b
x, b'
y) -> case (Context -> b -> Either Errors (Context, c)
p Context
ctx b
x, Context -> b' -> Either Errors (Context, c')
q Context
ctx b'
y) of
(Right (Context
_, c
x'), Right (Context
_, c'
y')) -> (Context, (c, c')) -> Either Errors (Context, (c, c'))
forall a b. b -> Either a b
Right (Context
ctx, (c
x', c'
y'))
(Left Errors
err, Either Errors (Context, c')
_) -> Errors -> Either Errors (Context, (c, c'))
forall a b. a -> Either a b
Left Errors
err
(Either Errors (Context, c)
_, Left Errors
err) -> Errors -> Either Errors (Context, (c, c'))
forall a b. a -> Either a b
Left Errors
err
instance ArrowZero Parser where
zeroArrow :: forall b c. Parser b c
zeroArrow = b ~> c
forall b c. Parser b c
failZero
instance ArrowPlus Parser where
(P Context -> b -> Either Errors (Context, c)
p) <+> :: forall b c. Parser b c -> Parser b c -> Parser b c
<+> (P Context -> b -> Either Errors (Context, c)
q) = (Context -> b -> Either Errors (Context, c)) -> Parser b c
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> b -> Either Errors (Context, c)) -> Parser b c)
-> (Context -> b -> Either Errors (Context, c)) -> Parser b c
forall a b. (a -> b) -> a -> b
$ \Context
ctx b
x -> case Context -> b -> Either Errors (Context, c)
p Context
ctx b
x of
Right (Context, c)
success -> (Context, c) -> Either Errors (Context, c)
forall a b. b -> Either a b
Right (Context, c)
success
Left Errors
errLeft -> case Context -> b -> Either Errors (Context, c)
q Context
ctx b
x of
Right (Context, c)
success -> (Context, c) -> Either Errors (Context, c)
forall a b. b -> Either a b
Right (Context, c)
success
Left Errors
errRight -> Errors -> Either Errors (Context, c)
forall a b. a -> Either a b
Left (Errors -> Either Errors (Context, c))
-> Errors -> Either Errors (Context, c)
forall a b. (a -> b) -> a -> b
$! (Errors
errLeft Errors -> Errors -> Errors
forall a. Semigroup a => a -> a -> a
<> Errors
errRight)
instance ArrowChoice Parser where
(P Context -> b -> Either Errors (Context, c)
p) +++ :: forall b c b' c'.
Parser b c -> Parser b' c' -> Parser (Either b b') (Either c c')
+++ (P Context -> b' -> Either Errors (Context, c')
q) = (Context -> Either b b' -> Either Errors (Context, Either c c'))
-> Parser (Either b b') (Either c c')
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Either b b' -> Either Errors (Context, Either c c'))
-> Parser (Either b b') (Either c c'))
-> (Context -> Either b b' -> Either Errors (Context, Either c c'))
-> Parser (Either b b') (Either c c')
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> \case
Left b
x -> case Context -> b -> Either Errors (Context, c)
p Context
ctx b
x of
Right (Context
ctx', c
y) -> (Context, Either c c') -> Either Errors (Context, Either c c')
forall a b. b -> Either a b
Right (Context
ctx', c -> Either c c'
forall a b. a -> Either a b
Left c
y)
Left Errors
err -> Errors -> Either Errors (Context, Either c c')
forall a b. a -> Either a b
Left Errors
err
Right b'
x -> case Context -> b' -> Either Errors (Context, c')
q Context
ctx b'
x of
Right (Context
ctx', c'
y) -> (Context, Either c c') -> Either Errors (Context, Either c c')
forall a b. b -> Either a b
Right (Context
ctx', c' -> Either c c'
forall a b. b -> Either a b
Right c'
y)
Left Errors
err -> Errors -> Either Errors (Context, Either c c')
forall a b. a -> Either a b
Left Errors
err
instance ArrowApply Parser where
app :: forall b c. Parser (Parser b c, b) c
app = (Context -> (Parser b c, b) -> Either Errors (Context, c))
-> Parser (Parser b c, b) c
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> (Parser b c, b) -> Either Errors (Context, c))
-> Parser (Parser b c, b) c)
-> (Context -> (Parser b c, b) -> Either Errors (Context, c))
-> Parser (Parser b c, b) c
forall a b. (a -> b) -> a -> b
$ \Context
ctx (Parser b c
p, b
x) -> Parser b c -> Context -> b -> Either Errors (Context, c)
forall a b.
Parser a b -> Context -> a -> Either Errors (Context, b)
unParser Parser b c
p Context
ctx b
x
fail :: ShortText -> a ~> b
fail :: forall a b. ShortText -> a ~> b
fail ShortText
msg = (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, b)) -> Parser a b)
-> (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
_ -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
msg Context
ctx))
failZero :: a ~> b
failZero :: forall b c. Parser b c
failZero = (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, b)) -> Parser a b)
-> (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
_ -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
"" Context
ctx))
liftMaybe ::
ShortText ->
(a -> Maybe b) ->
a ~> b
liftMaybe :: forall a b. ShortText -> (a -> Maybe b) -> a ~> b
liftMaybe ShortText
msg a -> Maybe b
f = (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> a -> Either Errors (Context, b)) -> Parser a b)
-> (Context -> a -> Either Errors (Context, b)) -> Parser a b
forall a b. (a -> b) -> a -> b
$ \Context
ctx a
x -> case a -> Maybe b
f a
x of
Just b
y -> (Context, b) -> Either Errors (Context, b)
forall a b. b -> Either a b
Right (Context
ctx, b
y)
Maybe b
Nothing -> Errors -> Either Errors (Context, b)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (ShortText -> Context -> Error
Error ShortText
msg Context
ctx))
withObject :: (Members ~> a) -> Value ~> a
withObject :: forall a. (Members ~> a) -> Value ~> a
withObject Members ~> a
membParser = Value ~> Members
object (Value ~> Members) -> (Members ~> a) -> Parser Value a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Members ~> a
membParser
withArray :: (Value ~> a) -> Value ~> SmallArray a
withArray :: forall a. (Value ~> a) -> Value ~> SmallArray a
withArray Value ~> a
elemParser = Value ~> Elements
array (Value ~> Elements)
-> Parser Elements (SmallArray a) -> Parser Value (SmallArray a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Value ~> a) -> Parser Elements (SmallArray a)
forall a. (Value ~> a) -> Elements ~> SmallArray a
map Value ~> a
elemParser
int :: Value ~> Int
int :: Value ~> Int
int = Value ~> Scientific
number (Value ~> Scientific) -> Parser Scientific Int -> Value ~> Int
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ShortText -> (Scientific -> Maybe Int) -> Parser Scientific Int
forall a b. ShortText -> (a -> Maybe b) -> a ~> b
liftMaybe ShortText
"number too big" Scientific -> Maybe Int
SCI.toInt
word16 :: Value ~> Word16
word16 :: Value ~> Word16
word16 = Value ~> Scientific
number (Value ~> Scientific)
-> Parser Scientific Word16 -> Value ~> Word16
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ShortText
-> (Scientific -> Maybe Word16) -> Parser Scientific Word16
forall a b. ShortText -> (a -> Maybe b) -> a ~> b
liftMaybe ShortText
"number too big" Scientific -> Maybe Word16
SCI.toWord16
word64 :: Value ~> Word64
word64 :: Value ~> Word64
word64 = Value ~> Scientific
number (Value ~> Scientific)
-> Parser Scientific Word64 -> Value ~> Word64
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ShortText
-> (Scientific -> Maybe Word64) -> Parser Scientific Word64
forall a b. ShortText -> (a -> Maybe b) -> a ~> b
liftMaybe ShortText
"number too big" Scientific -> Maybe Word64
SCI.toWord64
fromNull :: a -> Value ~> a
fromNull :: forall a. a -> Value ~> a
fromNull a
z = Value ~> ()
null (Value ~> ()) -> Parser () a -> Parser Value a
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a -> Parser () a
forall a. a -> Parser () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z