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

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

import Prelude hiding (fail)

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.List (find)
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 Data.Number.Scientific (Scientific)

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

newtype Parser a = Parser
  { Parser a -> Path -> Either Path a
runParser :: Path -> Either Path a }
  deriving stock a -> Parser b -> Parser a
(a -> b) -> Parser a -> Parser b
(forall a b. (a -> b) -> Parser a -> Parser b)
-> (forall a b. a -> Parser b -> Parser a) -> Functor Parser
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
<$ :: a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor

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

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

newtype MemberParser a = MemberParser
  { MemberParser a -> Path -> SmallArray Member -> Either Path a
runMemberParser :: Path -> SmallArray Member -> Either Path a }
  deriving stock a -> MemberParser b -> MemberParser a
(a -> b) -> MemberParser a -> MemberParser b
(forall a b. (a -> b) -> MemberParser a -> MemberParser b)
-> (forall a b. a -> MemberParser b -> MemberParser a)
-> Functor MemberParser
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
<$ :: a -> MemberParser b -> MemberParser a
$c<$ :: forall a b. a -> MemberParser b -> MemberParser a
fmap :: (a -> b) -> MemberParser a -> MemberParser b
$cfmap :: forall a b. (a -> b) -> MemberParser a -> MemberParser b
Functor

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

run :: Parser a -> Either Path a
run :: Parser a -> Either Path a
run (Parser Path -> Either Path a
f) = case Path -> Either Path a
f Path
Nil of
  Right a
a -> a -> Either Path a
forall a b. b -> Either a b
Right a
a
  Left Path
e -> Path -> Either Path a
forall a b. a -> Either a b
Left (Path -> Path
Path.reverse Path
e)

fail :: Parser a
fail :: Parser a
fail = (Path -> Either Path a) -> Parser a
forall a. (Path -> Either Path a) -> Parser a
Parser (\Path
e -> Path -> Either Path a
forall a b. a -> Either a b
Left Path
e)

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

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

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

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

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

int :: Scientific -> Parser Int
int :: Scientific -> Parser Int
int Scientific
m = case Scientific -> Maybe Int
SCI.toInt Scientific
m of
  Just Int
n -> Int -> Parser Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n
  Maybe Int
_ -> Parser Int
forall a. Parser a
fail

word16 :: Scientific -> Parser Word16
word16 :: Scientific -> Parser Word16
word16 Scientific
m = case Scientific -> Maybe Word16
SCI.toWord16 Scientific
m of
  Just Word16
n -> Word16 -> Parser Word16
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
n
  Maybe Word16
_ -> Parser Word16
forall a. Parser a
fail

word64 :: Scientific -> Parser Word64
word64 :: Scientific -> Parser Word64
word64 Scientific
m = case Scientific -> Maybe Word64
SCI.toWord64 Scientific
m of
  Just Word64
n -> Word64 -> Parser Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
n
  Maybe Word64
_ -> Parser Word64
forall a. Parser a
fail

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

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

key :: ShortText -> (Value -> Parser a) -> MemberParser a
key :: ShortText -> (Value -> Parser a) -> MemberParser a
key !ShortText
name Value -> Parser a
f = (Path -> SmallArray Member -> Either Path a) -> MemberParser a
forall a.
(Path -> SmallArray Member -> Either Path a) -> MemberParser a
MemberParser ((Path -> SmallArray Member -> Either Path a) -> MemberParser a)
-> (Path -> SmallArray Member -> Either Path a) -> MemberParser a
forall a b. (a -> b) -> a -> b
$ \Path
p SmallArray Member
mbrs ->
  let !p' :: Path
p' = ShortText -> Path -> Path
Key ShortText
name Path
p in
  case (Member -> Bool) -> SmallArray Member -> Maybe Member
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Member{key :: Member -> ShortText
key=ShortText
k} -> ShortText
k ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
name) SmallArray Member
mbrs of
    Maybe Member
Nothing -> Path -> Either Path a
forall a b. a -> Either a b
Left Path
p'
    Just Member{Value
value :: Member -> Value
value :: Value
value} -> Parser a -> Path -> Either Path a
forall a. Parser a -> Path -> Either Path a
runParser (Value -> Parser a
f Value
value) Path
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 :: (Value -> Parser a) -> SmallArray Value -> Parser (SmallArray a)
smallArray Value -> Parser a
f SmallArray Value
xs = (Path -> Either Path (SmallArray a)) -> Parser (SmallArray a)
forall a. (Path -> Either Path a) -> Parser a
Parser ((Path -> Either Path (SmallArray a)) -> Parser (SmallArray a))
-> (Path -> Either Path (SmallArray a)) -> Parser (SmallArray a)
forall a b. (a -> b) -> a -> b
$ \ !Path
p -> (forall s. ST s (Either Path (SmallArray a)))
-> Either Path (SmallArray a)
forall a. (forall s. ST s a) -> a
runST do
  let !len :: Int
len = SmallArray Value -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length SmallArray Value
xs
  SmallMutableArray s a
dst <- Int -> a -> ST s (SmallMutableArray (PrimState (ST s)) a)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
len a
forall a. a
errorThunk
  ExceptT Path (ST s) (SmallArray a)
-> ST s (Either Path (SmallArray a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Path (ST s) (SmallArray a)
 -> ST s (Either Path (SmallArray a)))
-> ExceptT Path (ST s) (SmallArray a)
-> ST s (Either Path (SmallArray a))
forall a b. (a -> b) -> a -> b
$ do
    Int
_ <- (Int -> Value -> ExceptT Path (ST s) Int)
-> Int -> SmallArray Value -> ExceptT Path (ST s) 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 <- ST s (Either Path a) -> ExceptT Path (ST s) a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Either Path a -> ST s (Either Path a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Parser a -> Path -> Either Path a
forall a. Parser a -> Path -> Either Path a
runParser (Value -> Parser a
f Value
x) (Int -> Path -> Path
Index Int
ix Path
p)))
        ST s () -> ExceptT Path (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> Int -> a -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst Int
ix a
y)
        Int -> ExceptT Path (ST s) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      ) Int
0 SmallArray Value
xs
    ST s (SmallArray a) -> ExceptT Path (ST s) (SmallArray a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SmallMutableArray (PrimState (ST s)) a -> ST s (SmallArray a)
forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s a
SmallMutableArray (PrimState (ST s)) a
dst)

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

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