{-# 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 (Text)
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 (Text -> Context -> Error
Error Text
"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 (Text -> Context -> Error
Error Text
"expected array" Context
ctx))

string :: Value ~> Text
string :: Value ~> Text
string = (Context -> Value -> Either Errors (Context, Text))
-> Value ~> Text
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, Text))
 -> Value ~> Text)
-> (Context -> Value -> Either Errors (Context, Text))
-> Value ~> Text
forall a b. (a -> b) -> a -> b
$ \Context
ctx Value
v -> case Value
v of
  String Text
str -> (Context, Text) -> Either Errors (Context, Text)
forall a b. b -> Either a b
Right (Context
ctx, Text
str)
  Value
_ -> Errors -> Either Errors (Context, Text)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (Text -> Context -> Error
Error Text
"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 ~> SmallArray Text
strings :: Value ~> SmallArray Text
strings = (Context -> Value -> Either Errors (Context, SmallArray Text))
-> Value ~> SmallArray Text
forall a b.
(Context -> a -> Either Errors (Context, b)) -> Parser a b
P ((Context -> Value -> Either Errors (Context, SmallArray Text))
 -> Value ~> SmallArray Text)
-> (Context -> Value -> Either Errors (Context, SmallArray Text))
-> Value ~> SmallArray Text
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, SmallArray Text)))
-> Either Errors (Context, SmallArray Text)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Either Errors (Context, SmallArray Text)))
 -> Either Errors (Context, SmallArray Text))
-> (forall s. ST s (Either Errors (Context, SmallArray Text)))
-> Either Errors (Context, SmallArray Text)
forall a b. (a -> b) -> a -> b
$ ExceptT Errors (ST s) (Context, SmallArray Text)
-> ST s (Either Errors (Context, SmallArray Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Errors (ST s) (Context, SmallArray Text)
 -> ST s (Either Errors (Context, SmallArray Text)))
-> ExceptT Errors (ST s) (Context, SmallArray Text)
-> ST s (Either Errors (Context, SmallArray Text))
forall a b. (a -> b) -> a -> b
$ do
    SmallArray Text
xs <-
      (Int -> Value -> ExceptT Errors (ST s) Text)
-> SmallArray Value -> ExceptT Errors (ST s) (SmallArray Text)
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 Text
s -> Text -> ExceptT Errors (ST s) Text
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
            Value
_ -> ST s (Either Errors Text) -> ExceptT Errors (ST s) Text
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Errors Text -> ST s (Either Errors Text)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Errors -> Either Errors Text
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (Text -> Context -> Error
Error Text
"expected string" (Int -> Context -> Context
Index Int
ix Context
ctx)))))
        )
        SmallArray Value
membs
    (Context, SmallArray Text)
-> ExceptT Errors (ST s) (Context, SmallArray Text)
forall a. a -> ExceptT Errors (ST s) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context
ctx, SmallArray Text
xs)
  Value
_ -> Errors -> Either Errors (Context, SmallArray Text)
forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (Text -> Context -> Error
Error Text
"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 (Text -> Context -> Error
Error Text
"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 (Text -> Context -> Error
Error Text
"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 (Text -> Context -> Error
Error Text
"expected null" Context
ctx))

newtype Members = Members {Members -> SmallArray Member
unMembers :: SmallArray Member}

member :: Text -> Members ~> Value
member :: Text -> Members ~> Value
member Text
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 (Text -> Context -> Context
Key Text
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 (Text -> Context -> Error
Error (Text
"key not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k) Context
ctx))
 where
  keyEq :: Member -> Bool
keyEq Member {Text
key :: Text
key :: Member -> Text
key} = Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key

-- | An optional member. Returns Nothing if the value is missing.
memberOpt :: Text -> Members ~> Maybe Value
memberOpt :: Text -> Members ~> Maybe Value
memberOpt Text
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 (Text -> Context -> Context
Key Text
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 {Text
key :: Member -> Text
key :: Text
key} = Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
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 {Text
key :: Member -> Text
key :: Text
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) (Text -> Context -> Context
Key Text
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 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 -> m (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 m) a -> Int -> a -> m ()
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 s a
Mutable SmallArray (PrimState m) a
dst Int
i a
y
              Int -> m (Either Errors ())
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Left Errors
err -> Either Errors () -> m (Either Errors ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors () -> m (Either Errors ()))
-> Either Errors () -> m (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 () -> m (Either Errors ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Errors () -> m (Either Errors ()))
-> Either Errors () -> m (Either Errors ())
forall a b. (a -> b) -> a -> b
$ () -> Either Errors ()
forall a b. b -> Either a b
Right ()
  Int -> ST s (Either Errors ())
forall {m :: * -> *}.
(PrimState m ~ s, PrimMonad m) =>
Int -> m (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 s a
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 :: Text -> a ~> b
fail :: forall a b. Text -> a ~> b
fail Text
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 (Text -> Context -> Error
Error Text
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 (Text -> Context -> Error
Error Text
"" Context
ctx))

liftMaybe ::
  -- | Message to display on decode error
  Text ->
  -- | Decode function
  (a -> Maybe b) ->
  a ~> b
liftMaybe :: forall a b. Text -> (a -> Maybe b) -> a ~> b
liftMaybe Text
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 (Text -> Context -> Error
Error Text
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
>>> Text -> (Scientific -> Maybe Int) -> Parser Scientific Int
forall a b. Text -> (a -> Maybe b) -> a ~> b
liftMaybe Text
"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
>>> Text -> (Scientific -> Maybe Word16) -> Parser Scientific Word16
forall a b. Text -> (a -> Maybe b) -> a ~> b
liftMaybe Text
"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
>>> Text -> (Scientific -> Maybe Word64) -> Parser Scientific Word64
forall a b. Text -> (a -> Maybe b) -> a ~> b
liftMaybe Text
"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