{-# LANGUAGE TemplateHaskell #-}

module Language.Parser.Ptera.TH.Syntax (
    T,

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

    GrammarM,
    SafeGrammar.MemberInitials (..),
    SafeGrammar.Rules (..),
    SafeGrammar.GrammarToken (..),
    RuleExprM,
    AltM,
    SafeGrammar.Expr,
    SemActM (..),
    semActM,
    HFList.HFList (..),
    HFList.DictF (..),
    HTExpList,
    pattern HNil,
    pattern (:*),
    TExpQ (..),
    Syntax.ActionTask (..),
    Syntax.ActionTaskResult (..),
    Syntax.getAction,
    Syntax.modifyAction,
    Syntax.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.Haskell.TH                      as TH
import qualified Language.Haskell.TH.Syntax               as TH
import qualified Language.Parser.Ptera.Syntax             as Syntax
import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar
import           Language.Parser.Ptera.TH.ParserLib
import qualified Language.Parser.Ptera.Data.HFList as HFList


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 -> (HTExpList us -> TH.Q (TH.TExp a))
    -> AltM ctx rules tokens elem a
e :: Expr rules tokens elem us
e@(SafeGrammar.UnsafeExpr Expr IntermNonTerminal Terminal elem us
ue) <:> :: Expr rules tokens elem us
-> (HTExpList us -> Q (TExp a)) -> AltM ctx rules tokens elem a
<:> HTExpList us -> Q (TExp 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.<:> (HTExpList us -> Q (TExp a))
-> Expr IntermNonTerminal Terminal elem us -> SemActM ctx us a
forall (us :: [*]) a (f :: * -> *) ctx.
(HTExpList us -> Q (TExp a)) -> T f us -> SemActM ctx us a
semAct HTExpList us -> Q (TExp a)
act Expr IntermNonTerminal Terminal elem us
ue

infixl 4 <:>

eps :: (HTExpList '[] -> TH.Q (TH.TExp a)) -> AltM ctx rules tokens elem a
eps :: (HTExpList '[] -> Q (TExp a)) -> AltM ctx rules tokens elem a
eps HTExpList '[] -> Q (TExp 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 (HTExpList '[] -> Q (TExp a)) -> T Any '[] -> SemActM ctx '[] a
forall (us :: [*]) a (f :: * -> *) ctx.
(HTExpList us -> Q (TExp a)) -> T f us -> SemActM ctx us a
semAct HTExpList '[] -> Q (TExp a)
act T Any '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil

(<::>)
    :: SafeGrammar.Expr rules tokens elem us
    -> (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a)))
    -> AltM ctx rules tokens elem a
e :: Expr rules tokens elem us
e@(SafeGrammar.UnsafeExpr Expr IntermNonTerminal Terminal elem us
ue) <::> :: Expr rules tokens elem us
-> (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> AltM ctx rules tokens elem a
<::> HTExpList us -> Q (TExp (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.<:> (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> Expr IntermNonTerminal Terminal elem us -> SemActM ctx us a
forall (us :: [*]) ctx a (f :: * -> *).
(HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T f us -> SemActM ctx us a
semActM HTExpList us -> Q (TExp (ActionTask ctx a))
act Expr IntermNonTerminal Terminal elem us
ue

infixl 4 <::>

epsM
    :: (HTExpList '[] -> TH.Q (TH.TExp (ActionTask ctx a)))
    -> AltM ctx rules tokens elem a
epsM :: (HTExpList '[] -> Q (TExp (ActionTask ctx a)))
-> AltM ctx rules tokens elem a
epsM HTExpList '[] -> Q (TExp (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 (HTExpList '[] -> Q (TExp (ActionTask ctx a)))
-> T Any '[] -> SemActM ctx '[] a
forall (us :: [*]) ctx a (f :: * -> *).
(HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T f us -> SemActM ctx us a
semActM HTExpList '[] -> Q (TExp (ActionTask ctx a))
act T Any '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil


type HTExpList = HFList.T TExpQ

newtype TExpQ a = TExpQ
    { TExpQ a -> Q (TExp a)
unTExpQ :: TH.Q (TH.TExp a)
    }

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

pattern (:*) :: TH.Q (TH.TExp u) -> HTExpList us -> HTExpList (u ': us)
pattern e $b:* :: Q (TExp u) -> HTExpList us -> HTExpList (u : us)
$m:* :: forall r u (us :: [*]).
HTExpList (u : us)
-> (Q (TExp u) -> HTExpList us -> r) -> (Void# -> r) -> r
:* es = HFList.HFCons (TExpQ e) es

infixr 6 :*


type SemActM :: Type -> [Type] -> Type -> Type
newtype SemActM ctx us a = UnsafeSemActM
    { SemActM ctx us a -> Q Exp
unsafeSemanticAction :: TH.Q TH.Exp
    }

type SemAct = SemActM ()

semActM
    :: (HTExpList us -> TH.Q (TH.TExp (Syntax.ActionTask ctx a)))
    -> HFList.T f us -> SemActM ctx us a
semActM :: (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T f us -> SemActM ctx us a
semActM HTExpList us -> Q (TExp (ActionTask ctx a))
f T f us
xs0 = Q Exp -> SemActM ctx us a
forall ctx (us :: [*]) a. Q Exp -> SemActM ctx us a
UnsafeSemActM Q Exp
go where
    go :: Q Exp
go = do
        ([Name]
ns, HTExpList us
args) <- T f us -> Q ([Name], HTExpList us)
forall (f :: * -> *) (us :: [*]).
T f us -> Q ([Name], HTExpList us)
actArgs T f us
xs0
        Name
l <- IntermNonTerminal -> Q Name
TH.newName IntermNonTerminal
"pteraTHSemActArgs"
        let lp :: Q Pat
lp = Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Pat
TH.VarP Name
l
        let le :: Q Exp
le = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Exp
TH.VarE Name
l
        let lp0 :: Q Pat
lp0 = Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure do [Pat] -> Pat
TH.ListP [Name -> Pat
TH.VarP Name
n | Name
n <- [Name]
ns]
        [e|\ $(lp) -> case $(le) of
            $(lp0) ->
                $(TH.unType <$> f args)
            _ ->
                error "unreachable: unexpected arguments"
            |]

    actArgs :: HFList.T f us -> TH.Q ([TH.Name], HTExpList us)
    actArgs :: T f us -> Q ([Name], HTExpList us)
actArgs = \case
        T f us
HFList.HFNil ->
            ([Name], HTExpList '[]) -> Q ([Name], HTExpList '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], HTExpList '[]
HNil)
        HFList.HFCons f x
_ HFList f xs
xs -> do
            Name
n <- IntermNonTerminal -> Q Name
TH.newName IntermNonTerminal
"pteraTHSemActArg"
            let ne :: Q (TExp ReduceArgument)
ne = Q Exp -> Q (TExp ReduceArgument)
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce do Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Exp
TH.VarE Name
n
            let arg :: Q (TExp x)
arg = [||pteraTHUnsafeExtractReduceArgument $$(ne)||]
            ([Name]
ns, HTExpList xs
args) <- HFList f xs -> Q ([Name], HTExpList xs)
forall (f :: * -> *) (us :: [*]).
T f us -> Q ([Name], HTExpList us)
actArgs HFList f xs
xs
            ([Name], HTExpList (x : xs)) -> Q ([Name], HTExpList (x : xs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ns, Q (TExp x)
arg Q (TExp x) -> HTExpList xs -> HTExpList (x : xs)
forall u (us :: [*]).
Q (TExp u) -> HTExpList us -> HTExpList (u : us)
:* HTExpList xs
args)

semAct
    :: (HTExpList us -> TH.Q (TH.TExp a))
    -> HFList.T f us -> SemActM ctx us a
semAct :: (HTExpList us -> Q (TExp a)) -> T f us -> SemActM ctx us a
semAct HTExpList us -> Q (TExp a)
f = (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T f us -> SemActM ctx us a
forall (us :: [*]) ctx a (f :: * -> *).
(HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T f us -> SemActM ctx us a
semActM do \HTExpList us
us -> [||pteraTHActionTaskPure $$(f us)||]