{-# language BangPatterns #-}
{-# language BlockArguments #-}
{-# language DeriveFunctor #-}
{-# language DerivingStrategies #-}
{-# language DuplicateRecordFields #-}
{-# language KindSignatures #-}
{-# language LambdaCase #-}
{-# language NamedFieldPuns #-}
{-# language RankNTypes #-}
{-# language OverloadedStrings #-}

module Json.Parser
  ( Parser(..)
  , MemberParser(..)
    -- * Run
  , run
    -- * Object Parsing
  , key
  , keyOptNull
  , members
    -- * Arrays
  , smallArray
  , foldSmallArray
  , traverseMembers
    -- * Specific Data Constructors
  , object
  , array
  , number
  , boolean
  , string
    -- * Trivial Combinators
  , int
  , int32
  , word16
  , word64
    -- * Failing
  , fail
    -- * Modified Context 
  , contextually
  ) where

import Prelude hiding (fail)

import Control.Applicative (Alternative(..))
import Control.Monad.ST (runST)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT(ExceptT),runExceptT)
import Data.Foldable (foldlM)
import Data.Int (Int32)
import Data.List (find)
import Data.Number.Scientific (Scientific)
import Data.Primitive (SmallArray)
import Data.Text.Short (ShortText)
import Data.Word (Word16,Word64)
import Json (Value(Object,Array,Number),Member(Member))
-- import Json.Path (Path(Nil,Key,Index))
import Json.Context (Context(Top,Key,Index))
import Json.Errors (Errors)
import Json.Error (Error(..))

import qualified Data.Number.Scientific as SCI
import qualified Data.Primitive as PM
import qualified Json
import qualified Json.Errors as Errors

newtype Parser a = Parser
  { forall a. Parser a -> Context -> Either Errors a
runParser :: Context -> Either Errors a }
  deriving stock forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor

instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
a = forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
_ -> forall a b. b -> Either a b
Right a
a)
  Parser Context -> Either Errors (a -> b)
f <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser Context -> Either Errors a
g = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Context
p -> do
    a -> b
h <- Context -> Either Errors (a -> b)
f Context
p
    a
y <- Context -> Either Errors a
g Context
p
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)

instance Alternative Parser where
  empty :: forall a. Parser a
empty = forall a. ShortText -> Parser a
fail forall a. Monoid a => a
mempty
  Parser a
f <|> :: forall a. Parser a -> Parser a -> Parser a
<|> Parser a
g = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Context
p -> case forall a. Parser a -> Context -> Either Errors a
runParser Parser a
f Context
p of
    Right a
x -> forall a b. b -> Either a b
Right a
x
    Left Errors
aErrs -> case forall a. Parser a -> Context -> Either Errors a
runParser Parser a
g Context
p of
      Right a
y -> forall a b. b -> Either a b
Right a
y
      Left Errors
bErrs -> forall a b. a -> Either a b
Left (Errors
aErrs forall a. Semigroup a => a -> a -> a
<> Errors
bErrs)

instance Monad Parser where
  Parser Context -> Either Errors a
f >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
g = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Context
p -> do
    a
x <- Context -> Either Errors a
f Context
p
    forall a. Parser a -> Context -> Either Errors a
runParser (a -> Parser b
g a
x) Context
p

newtype MemberParser a = MemberParser
  { forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser :: Context -> SmallArray Member -> Either Errors a }
  deriving stock forall a b. a -> MemberParser b -> MemberParser a
forall a b. (a -> b) -> MemberParser a -> MemberParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MemberParser b -> MemberParser a
$c<$ :: forall a b. a -> MemberParser b -> MemberParser a
fmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
$cfmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
Functor

instance Applicative MemberParser where
  pure :: forall a. a -> MemberParser a
pure a
a = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser (\Context
_ SmallArray Member
_ -> forall a b. b -> Either a b
Right a
a)
  MemberParser Context -> SmallArray Member -> Either Errors (a -> b)
f <*> :: forall a b.
MemberParser (a -> b) -> MemberParser a -> MemberParser b
<*> MemberParser Context -> SmallArray Member -> Either Errors a
g = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs -> do
    a -> b
h <- Context -> SmallArray Member -> Either Errors (a -> b)
f Context
p SmallArray Member
mbrs
    a
y <- Context -> SmallArray Member -> Either Errors a
g Context
p SmallArray Member
mbrs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
h a
y)

instance Alternative MemberParser where
  empty :: forall a. MemberParser a
empty = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
_ -> forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton Error{$sel:message:Error :: ShortText
message=forall a. Monoid a => a
mempty,$sel:context:Error :: Context
context=Context
p})
  MemberParser a
a <|> :: forall a. MemberParser a -> MemberParser a -> MemberParser a
<|> MemberParser a
b = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
    case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
a Context
p SmallArray Member
mbrs of
      Right a
x -> forall a b. b -> Either a b
Right a
x
      Left Errors
aErrs -> case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
b Context
p SmallArray Member
mbrs of
        Right a
y -> forall a b. b -> Either a b
Right a
y
        Left Errors
bErrs -> forall a b. a -> Either a b
Left (Errors
aErrs forall a. Semigroup a => a -> a -> a
<> Errors
bErrs)

instance Monad MemberParser where
  MemberParser a
parser >>= :: forall a b.
MemberParser a -> (a -> MemberParser b) -> MemberParser b
>>= a -> MemberParser b
k = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
    case forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser MemberParser a
parser Context
p SmallArray Member
mbrs of
      Left Errors
p' -> forall a b. a -> Either a b
Left Errors
p'
      Right a
x -> forall a.
MemberParser a -> Context -> SmallArray Member -> Either Errors a
runMemberParser (a -> MemberParser b
k a
x) Context
p SmallArray Member
mbrs

run :: Parser a -> Either Errors a
run :: forall a. Parser a -> Either Errors a
run (Parser Context -> Either Errors a
f) = case Context -> Either Errors a
f Context
Top of
  Right a
a -> forall a b. b -> Either a b
Right a
a
  Left Errors
e -> forall a b. a -> Either a b
Left Errors
e

fail :: ShortText -> Parser a
fail :: forall a. ShortText -> Parser a
fail !ShortText
msg = forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
e -> forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton Error{$sel:context:Error :: Context
context=Context
e,$sel:message:Error :: ShortText
message=ShortText
msg}))

object :: Value -> Parser (SmallArray Member)
object :: Value -> Parser (SmallArray Member)
object = \case
  Object SmallArray Member
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Member
xs
  Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected object"

array :: Value -> Parser (SmallArray Value)
array :: Value -> Parser (SmallArray Value)
array = \case
  Array SmallArray Value
xs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallArray Value
xs
  Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected array"

members :: MemberParser a -> SmallArray Member -> Parser a
members :: forall a. MemberParser a -> SmallArray Member -> Parser a
members (MemberParser Context -> SmallArray Member -> Either Errors a
f) SmallArray Member
mbrs = forall a. (Context -> Either Errors a) -> Parser a
Parser (\Context
p -> Context -> SmallArray Member -> Either Errors a
f Context
p SmallArray Member
mbrs)

number :: Value -> Parser Scientific
number :: Value -> Parser Scientific
number = \case
  Number Scientific
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Scientific
n
  Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number"

string :: Value -> Parser ShortText
string :: Value -> Parser ShortText
string = \case
  Json.String ShortText
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
n
  Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected string"

int :: Scientific -> Parser Int
int :: Scientific -> Parser Int
int Scientific
m = case Scientific -> Maybe Int
SCI.toInt Scientific
m of
  Just Int
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
  Maybe Int
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number in signed machine integer range"

int32 :: Scientific -> Parser Int32
int32 :: Scientific -> Parser Int32
int32 Scientific
m = case Scientific -> Maybe Int32
SCI.toInt32 Scientific
m of
  Just Int32
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int32
n
  Maybe Int32
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number in range [-2^31,2^31-1)"

word16 :: Scientific -> Parser Word16
word16 :: Scientific -> Parser Word16
word16 Scientific
m = case Scientific -> Maybe Word16
SCI.toWord16 Scientific
m of
  Just Word16
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
n
  Maybe Word16
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^16)"

word64 :: Scientific -> Parser Word64
word64 :: Scientific -> Parser Word64
word64 Scientific
m = case Scientific -> Maybe Word64
SCI.toWord64 Scientific
m of
  Just Word64
n -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
n
  Maybe Word64
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected number in range [0,2^64)"

boolean :: Value -> Parser Bool
boolean :: Value -> Parser Bool
boolean = \case
  Value
Json.True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Value
Json.False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Value
_ -> forall a. ShortText -> Parser a
fail ShortText
"expected boolean"

-- members :: Parser Value (Chunks Member)
-- members = _

key :: ShortText -> (Value -> Parser a) -> MemberParser a
key :: forall a. ShortText -> (Value -> Parser a) -> MemberParser a
key !ShortText
name Value -> Parser a
f = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
  let !p' :: Context
p' = ShortText -> Context -> Context
Key ShortText
name Context
p in
  case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member{key :: Member -> ShortText
key=ShortText
k} -> ShortText
k forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
    Maybe Member
Nothing -> forall a b. a -> Either a b
Left (Error -> Errors
Errors.singleton (Error{$sel:context:Error :: Context
context=Context
p',$sel:message:Error :: ShortText
message=ShortText
"key not found: " forall a. Semigroup a => a -> a -> a
<> ShortText
name}))
    Just Member{Value
value :: Member -> Value
value :: Value
value} -> forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
value) Context
p'

-- | Variant of 'key' that supplies the JSON value @null@ to the
-- callback if the key is not found. Using this parser combinators implies
-- that there is no distinction between @null@ and an absent value in
-- the encoding scheme.
keyOptNull :: ShortText -> (Value -> Parser a) -> MemberParser a
keyOptNull :: forall a. ShortText -> (Value -> Parser a) -> MemberParser a
keyOptNull !ShortText
name Value -> Parser a
f = forall a.
(Context -> SmallArray Member -> Either Errors a) -> MemberParser a
MemberParser forall a b. (a -> b) -> a -> b
$ \Context
p SmallArray Member
mbrs ->
  let !p' :: Context
p' = ShortText -> Context -> Context
Key ShortText
name Context
p
      val :: Value
val = case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member{key :: Member -> ShortText
key=ShortText
k} -> ShortText
k forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
        Maybe Member
Nothing -> Value
Json.Null
        Just Member{Value
value :: Value
value :: Member -> Value
value} -> Value
value
   in forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
val) Context
p'

-- object2 ::
--      (a -> b -> c)
--   -> ShortText -> Parser a
--   -> ShortText -> Parser b
--   -> Parser c
-- object2 f ka pa kb pb = Parser $ \p v -> case v 

-- elements :: Parser Value (Chunks Value)
-- elements = _

-- | Run the same parser against every element in a 'SmallArray'. This adjusts
-- the context at each element.
smallArray :: (Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a)
smallArray :: forall a.
(Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a)
smallArray Value -> Parser a
f SmallArray Value
xs = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
  let !len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Value
xs
  SmallMutableArray s a
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len forall a. a
errorThunk
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    Int
_ <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\Int
ix Value
x -> do
        !a
y <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> Context -> Either Errors a
runParser (Value -> Parser a
f Value
x) (Int -> Context -> Context
Index Int
ix Context
p)))
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
dst Int
ix a
y)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
      ) Int
0 SmallArray Value
xs
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
dst)

-- | Run the parser against every element in a 'SmallArray', updating an
-- accumulator at each step. Folds from left to right. This adjusts
-- the context at each element. Typically, type @a@ is @Value@.
foldSmallArray :: (b -> a -> Parser b) -> b -> SmallArray a -> Parser b
{-# inline foldSmallArray #-}
foldSmallArray :: forall b a. (b -> a -> Parser b) -> b -> SmallArray a -> Parser b
foldSmallArray b -> a -> Parser b
f b
acc0 SmallArray a
xs = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
  -- TODO: make sure tuples get elided
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    (!Int
_,b
r) <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\( !Int
ix, !b
acc) a
x -> do
        !b
acc' <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> Context -> Either Errors a
runParser (b -> a -> Parser b
f b
acc a
x) (Int -> Context -> Context
Index Int
ix Context
p)))
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1, b
acc')
      ) (Int
0,b
acc0) SmallArray a
xs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r

-- | Traverse the members. The adjusts the context at each member.
traverseMembers :: (Member -> Parser a) -> SmallArray Member -> Parser (SmallArray a)
traverseMembers :: forall a.
(Member -> Parser a) -> SmallArray Member -> Parser (SmallArray a)
traverseMembers Member -> Parser a
f !SmallArray Member
xs = forall a. (Context -> Either Errors a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \ !Context
p -> forall a. (forall s. ST s a) -> a
runST do
  let !len :: Int
len = forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Member
xs
  SmallMutableArray s a
dst <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len forall a. a
errorThunk
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    !Int
_ <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
      (\ !Int
ix x :: Member
x@Member{key :: Member -> ShortText
key=ShortText
k} -> do
        !a
y <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Parser a -> Context -> Either Errors a
runParser (Member -> Parser a
f Member
x) (ShortText -> Context -> Context
Key ShortText
k Context
p)))
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
dst Int
ix a
y)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
      ) Int
0 SmallArray Member
xs
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
dst)

errorThunk :: a
{-# noinline errorThunk #-}
errorThunk :: forall a. a
errorThunk = forall a. [Char] -> a
errorWithoutStackTrace [Char]
"Json.Parser: implementation mistake"

-- | Run a parser in a modified context.
contextually :: (Context -> Context) -> Parser a -> Parser a
{-# inline contextually #-}
contextually :: forall a. (Context -> Context) -> Parser a -> Parser a
contextually Context -> Context
f (Parser Context -> Either Errors a
g) = forall a. (Context -> Either Errors a) -> Parser a
Parser
  (\Context
p ->
    let !p' :: Context
p' = Context -> Context
f Context
p
     in Context -> Either Errors a
g Context
p'
  )