module Language.Parser.Ptera.Syntax (
    T,

    HasField (..),
    SafeGrammar.HasRuleExprField (..),
    SafeGrammar.TokensTag,
    SafeGrammar.RulesTag,
    SafeGrammar.RuleExprType,

    GrammarM,
    SafeGrammar.MemberInitials (..),
    SafeGrammar.Rules (..),
    SafeGrammar.GrammarToken (..),
    RuleExprM,
    AltM,
    SafeGrammar.Expr,
    HFList.HFList (..),
    HFList.DictF (..),
    HList,
    pattern HNil,
    pattern (:*),
    SemActM (..),
    semActM,
    ActionTask (..),
    ActionTaskResult (..),
    getAction,
    modifyAction,
    failAction,

    Grammar,
    RuleExpr,
    Alt,
    SemAct,
    semAct,

    SafeGrammar.fixGrammar,
    SafeGrammar.ruleExpr,
    (SafeGrammar.<^>),
    (<:>),
    eps,
    (<::>),
    epsM,
    SafeGrammar.var,
    SafeGrammar.varA,
    SafeGrammar.tok,
    SafeGrammar.TokensMember (..),
    SafeGrammar.tokA,
) where

import           Language.Parser.Ptera.Prelude

import qualified Language.Parser.Ptera.Data.HFList as HFList
import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar


type T ctx = GrammarM ctx

type GrammarM ctx = SafeGrammar.Grammar (SemActM ctx)
type RuleExprM ctx = SafeGrammar.RuleExpr (SemActM ctx)
type AltM ctx = SafeGrammar.Alt (SemActM ctx)

type Grammar = GrammarM ()
type RuleExpr = RuleExprM ()
type Alt = AltM ()


(<:>)
    :: SafeGrammar.Expr rules tokens elem us -> (HList us -> a)
    -> AltM ctx rules tokens elem a
Expr rules tokens elem us
e <:> :: Expr rules tokens elem us
-> (HList us -> a) -> AltM ctx rules tokens elem a
<:> HList us -> a
act = Expr rules tokens elem us
e Expr rules tokens elem us
-> SemActM ctx us a -> AltM ctx rules tokens elem a
forall rules tokens elem (us :: [*]) (action :: [*] -> * -> *) a.
Expr rules tokens elem us
-> action us a -> Alt action rules tokens elem a
SafeGrammar.<:> (HList us -> a) -> SemActM ctx us a
forall (us :: [*]) a ctx. (HList us -> a) -> SemActM ctx us a
semAct HList us -> a
act

infixl 4 <:>

eps :: (HList '[] -> a) -> AltM ctx rules tokens elem a
eps :: (HList '[] -> a) -> AltM ctx rules tokens elem a
eps HList '[] -> a
act = SemActM ctx '[] a -> AltM ctx rules tokens elem a
forall (action :: [*] -> * -> *) a rules tokens elem.
action '[] a -> Alt action rules tokens elem a
SafeGrammar.eps do (HList '[] -> a) -> SemActM ctx '[] a
forall (us :: [*]) a ctx. (HList us -> a) -> SemActM ctx us a
semAct HList '[] -> a
act

(<::>)
    :: SafeGrammar.Expr rules tokens elem us -> (HList us -> ActionTask ctx a)
    -> AltM ctx rules tokens elem a
Expr rules tokens elem us
e <::> :: Expr rules tokens elem us
-> (HList us -> ActionTask ctx a) -> AltM ctx rules tokens elem a
<::> HList us -> ActionTask ctx a
act = Expr rules tokens elem us
e Expr rules tokens elem us
-> SemActM ctx us a -> AltM ctx rules tokens elem a
forall rules tokens elem (us :: [*]) (action :: [*] -> * -> *) a.
Expr rules tokens elem us
-> action us a -> Alt action rules tokens elem a
SafeGrammar.<:> (HList us -> ActionTask ctx a) -> SemActM ctx us a
forall (us :: [*]) ctx a.
(HList us -> ActionTask ctx a) -> SemActM ctx us a
semActM HList us -> ActionTask ctx a
act

infixl 4 <::>

epsM :: (HList '[] -> ActionTask ctx a) -> AltM ctx rules tokens elem a
epsM :: (HList '[] -> ActionTask ctx a) -> AltM ctx rules tokens elem a
epsM HList '[] -> ActionTask ctx a
act = SemActM ctx '[] a -> AltM ctx rules tokens elem a
forall (action :: [*] -> * -> *) a rules tokens elem.
action '[] a -> Alt action rules tokens elem a
SafeGrammar.eps do (HList '[] -> ActionTask ctx a) -> SemActM ctx '[] a
forall (us :: [*]) ctx a.
(HList us -> ActionTask ctx a) -> SemActM ctx us a
semActM HList '[] -> ActionTask ctx a
act


type HList = HFList.T Identity

pattern HNil :: HList '[]
pattern $bHNil :: HList '[]
$mHNil :: forall r. HList '[] -> (Void# -> r) -> (Void# -> r) -> r
HNil = HFList.HFNil

pattern (:*) :: u -> HList us -> HList (u ': us)
pattern x $b:* :: u -> HList us -> HList (u : us)
$m:* :: forall r u (us :: [*]).
HList (u : us) -> (u -> HList us -> r) -> (Void# -> r) -> r
:* xs = HFList.HFCons (Identity x) xs

infixr 6 :*


newtype SemActM ctx us a = SemActM
    { SemActM ctx us a -> HList us -> ActionTask ctx a
semanticAction :: HList us -> ActionTask ctx a
    }
    deriving a -> SemActM ctx us b -> SemActM ctx us a
(a -> b) -> SemActM ctx us a -> SemActM ctx us b
(forall a b. (a -> b) -> SemActM ctx us a -> SemActM ctx us b)
-> (forall a b. a -> SemActM ctx us b -> SemActM ctx us a)
-> Functor (SemActM ctx us)
forall ctx (us :: [*]) a b.
a -> SemActM ctx us b -> SemActM ctx us a
forall ctx (us :: [*]) a b.
(a -> b) -> SemActM ctx us a -> SemActM ctx us b
forall a b. a -> SemActM ctx us b -> SemActM ctx us a
forall a b. (a -> b) -> SemActM ctx us a -> SemActM ctx us b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SemActM ctx us b -> SemActM ctx us a
$c<$ :: forall ctx (us :: [*]) a b.
a -> SemActM ctx us b -> SemActM ctx us a
fmap :: (a -> b) -> SemActM ctx us a -> SemActM ctx us b
$cfmap :: forall ctx (us :: [*]) a b.
(a -> b) -> SemActM ctx us a -> SemActM ctx us b
Functor

type SemAct = SemActM ()

semActM :: (HList us -> ActionTask ctx a) -> SemActM ctx us a
semActM :: (HList us -> ActionTask ctx a) -> SemActM ctx us a
semActM = (HList us -> ActionTask ctx a) -> SemActM ctx us a
forall ctx (us :: [*]) a.
(HList us -> ActionTask ctx a) -> SemActM ctx us a
SemActM

semAct :: (HList us -> a) -> SemActM ctx us a
semAct :: (HList us -> a) -> SemActM ctx us a
semAct HList us -> a
f = (HList us -> ActionTask ctx a) -> SemActM ctx us a
forall ctx (us :: [*]) a.
(HList us -> ActionTask ctx a) -> SemActM ctx us a
SemActM \HList us
l -> a -> ActionTask ctx a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do HList us -> a
f HList us
l


newtype ActionTask ctx a = ActionTask
    { ActionTask ctx a -> ctx -> ActionTaskResult ctx a
runActionTask :: ctx -> ActionTaskResult ctx a
    }
    deriving a -> ActionTask ctx b -> ActionTask ctx a
(a -> b) -> ActionTask ctx a -> ActionTask ctx b
(forall a b. (a -> b) -> ActionTask ctx a -> ActionTask ctx b)
-> (forall a b. a -> ActionTask ctx b -> ActionTask ctx a)
-> Functor (ActionTask ctx)
forall a b. a -> ActionTask ctx b -> ActionTask ctx a
forall a b. (a -> b) -> ActionTask ctx a -> ActionTask ctx b
forall ctx a b. a -> ActionTask ctx b -> ActionTask ctx a
forall ctx a b. (a -> b) -> ActionTask ctx a -> ActionTask ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ActionTask ctx b -> ActionTask ctx a
$c<$ :: forall ctx a b. a -> ActionTask ctx b -> ActionTask ctx a
fmap :: (a -> b) -> ActionTask ctx a -> ActionTask ctx b
$cfmap :: forall ctx a b. (a -> b) -> ActionTask ctx a -> ActionTask ctx b
Functor

data ActionTaskResult ctx a
    = ActionTaskFail
    | ActionTaskResult a
    | ActionTaskModifyResult ctx a
    deriving (ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
(ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool)
-> (ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool)
-> Eq (ActionTaskResult ctx a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ctx a.
(Eq a, Eq ctx) =>
ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
/= :: ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
$c/= :: forall ctx a.
(Eq a, Eq ctx) =>
ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
== :: ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
$c== :: forall ctx a.
(Eq a, Eq ctx) =>
ActionTaskResult ctx a -> ActionTaskResult ctx a -> Bool
Eq, Int -> ActionTaskResult ctx a -> ShowS
[ActionTaskResult ctx a] -> ShowS
ActionTaskResult ctx a -> String
(Int -> ActionTaskResult ctx a -> ShowS)
-> (ActionTaskResult ctx a -> String)
-> ([ActionTaskResult ctx a] -> ShowS)
-> Show (ActionTaskResult ctx a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ctx a.
(Show a, Show ctx) =>
Int -> ActionTaskResult ctx a -> ShowS
forall ctx a.
(Show a, Show ctx) =>
[ActionTaskResult ctx a] -> ShowS
forall ctx a.
(Show a, Show ctx) =>
ActionTaskResult ctx a -> String
showList :: [ActionTaskResult ctx a] -> ShowS
$cshowList :: forall ctx a.
(Show a, Show ctx) =>
[ActionTaskResult ctx a] -> ShowS
show :: ActionTaskResult ctx a -> String
$cshow :: forall ctx a.
(Show a, Show ctx) =>
ActionTaskResult ctx a -> String
showsPrec :: Int -> ActionTaskResult ctx a -> ShowS
$cshowsPrec :: forall ctx a.
(Show a, Show ctx) =>
Int -> ActionTaskResult ctx a -> ShowS
Show, a -> ActionTaskResult ctx b -> ActionTaskResult ctx a
(a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b
(forall a b.
 (a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b)
-> (forall a b.
    a -> ActionTaskResult ctx b -> ActionTaskResult ctx a)
-> Functor (ActionTaskResult ctx)
forall a b. a -> ActionTaskResult ctx b -> ActionTaskResult ctx a
forall a b.
(a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b
forall ctx a b.
a -> ActionTaskResult ctx b -> ActionTaskResult ctx a
forall ctx a b.
(a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ActionTaskResult ctx b -> ActionTaskResult ctx a
$c<$ :: forall ctx a b.
a -> ActionTaskResult ctx b -> ActionTaskResult ctx a
fmap :: (a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b
$cfmap :: forall ctx a b.
(a -> b) -> ActionTaskResult ctx a -> ActionTaskResult ctx b
Functor)

getAction :: ActionTask ctx ctx
getAction :: ActionTask ctx ctx
getAction = (ctx -> ActionTaskResult ctx ctx) -> ActionTask ctx ctx
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
ctx0 -> ctx -> ActionTaskResult ctx ctx
forall ctx a. a -> ActionTaskResult ctx a
ActionTaskResult ctx
ctx0

modifyAction :: (ctx -> ctx) -> ActionTask ctx ()
modifyAction :: (ctx -> ctx) -> ActionTask ctx ()
modifyAction ctx -> ctx
f = (ctx -> ActionTaskResult ctx ()) -> ActionTask ctx ()
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
ctx0 -> ctx -> () -> ActionTaskResult ctx ()
forall ctx a. ctx -> a -> ActionTaskResult ctx a
ActionTaskModifyResult (ctx -> ctx
f ctx
ctx0) ()

failAction :: ActionTask ctx a
failAction :: ActionTask ctx a
failAction = (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
_ -> ActionTaskResult ctx a
forall ctx a. ActionTaskResult ctx a
ActionTaskFail

instance Applicative (ActionTask ctx) where
    pure :: a -> ActionTask ctx a
pure a
x = (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
_ -> a -> ActionTaskResult ctx a
forall ctx a. a -> ActionTaskResult ctx a
ActionTaskResult a
x
    ActionTask ctx -> ActionTaskResult ctx (a -> b)
mf <*> :: ActionTask ctx (a -> b) -> ActionTask ctx a -> ActionTask ctx b
<*> ActionTask ctx -> ActionTaskResult ctx a
mx = (ctx -> ActionTaskResult ctx b) -> ActionTask ctx b
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
ctx0 -> case ctx -> ActionTaskResult ctx (a -> b)
mf ctx
ctx0 of
        ActionTaskResult ctx (a -> b)
ActionTaskFail ->
            ActionTaskResult ctx b
forall ctx a. ActionTaskResult ctx a
ActionTaskFail
        ActionTaskResult a -> b
f -> case ctx -> ActionTaskResult ctx a
mx ctx
ctx0 of
            ActionTaskResult ctx a
ActionTaskFail ->
                ActionTaskResult ctx b
forall ctx a. ActionTaskResult ctx a
ActionTaskFail
            ActionTaskResult a
x ->
                b -> ActionTaskResult ctx b
forall ctx a. a -> ActionTaskResult ctx a
ActionTaskResult do a -> b
f a
x
            ActionTaskModifyResult ctx
ctx1 a
x ->
                ctx -> b -> ActionTaskResult ctx b
forall ctx a. ctx -> a -> ActionTaskResult ctx a
ActionTaskModifyResult ctx
ctx1 do a -> b
f a
x
        ActionTaskModifyResult ctx
ctx1 a -> b
f -> case ctx -> ActionTaskResult ctx a
mx ctx
ctx1 of
            ActionTaskResult ctx a
ActionTaskFail ->
                ActionTaskResult ctx b
forall ctx a. ActionTaskResult ctx a
ActionTaskFail
            ActionTaskResult a
x ->
                ctx -> b -> ActionTaskResult ctx b
forall ctx a. ctx -> a -> ActionTaskResult ctx a
ActionTaskModifyResult ctx
ctx1 do a -> b
f a
x
            ActionTaskModifyResult ctx
ctx2 a
x ->
                ctx -> b -> ActionTaskResult ctx b
forall ctx a. ctx -> a -> ActionTaskResult ctx a
ActionTaskModifyResult ctx
ctx2 do a -> b
f a
x

instance Monad (ActionTask ctx) where
    ActionTask ctx -> ActionTaskResult ctx a
mx >>= :: ActionTask ctx a -> (a -> ActionTask ctx b) -> ActionTask ctx b
>>= a -> ActionTask ctx b
f = (ctx -> ActionTaskResult ctx b) -> ActionTask ctx b
forall ctx a. (ctx -> ActionTaskResult ctx a) -> ActionTask ctx a
ActionTask \ctx
ctx0 -> case ctx -> ActionTaskResult ctx a
mx ctx
ctx0 of
        ActionTaskResult ctx a
ActionTaskFail ->
            ActionTaskResult ctx b
forall ctx a. ActionTaskResult ctx a
ActionTaskFail
        ActionTaskResult a
x ->
            ActionTask ctx b -> ctx -> ActionTaskResult ctx b
forall ctx a. ActionTask ctx a -> ctx -> ActionTaskResult ctx a
runActionTask (a -> ActionTask ctx b
f a
x) ctx
ctx0
        ActionTaskModifyResult ctx
ctx1 a
x ->
            ActionTask ctx b -> ctx -> ActionTaskResult ctx b
forall ctx a. ActionTask ctx a -> ctx -> ActionTaskResult ctx a
runActionTask (a -> ActionTask ctx b
f a
x) ctx
ctx1