{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module Json.Arrow
  ( Parser
  , type (~>)

    -- * Run Parser
  , run

    -- * Primitive Parsers
  , object
  , array
  , string
  , strings
  , number
  , boolean
  , null

    -- ** Object Members
  , Members (..)
  , member
  , memberOpt
  , foldMembers

    -- ** Array Elements
  , Elements
  , foldl'
  , map

    -- * Primitive Combinators
  , fail
  , failZero

    -- * Trivial Combinators
  , withObject
  , withArray
  , fromNull
  , int
  , word16
  , word64

    -- * Conversion
  , 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 ->
      -- \^ reverse list of json keys & indices that have been entered
      a ->
      -- \^ value to parse
      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))

{- | Parse an array of strings. For example:

> ["hello","world"]

Failure context includes the index of non-string value if any values in
the array are not strings.
-}
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

-- | An optional member. Returns Nothing if the value is missing.
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 ::
  -- | Message to display on decode error
  ShortText ->
  -- | Decode function
  (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