{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

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

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

    GrammarM,
    SafeGrammar.MemberInitials (..),
    SafeGrammar.Rules (..),
    SafeGrammar.GrammarToken (..),
    RuleExprM,
    AltM,
    TypedExpr,
    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,
    (<^>),
    eps,
    (<:>),
    (<::>),
    var,
    varA,
    tok,
    SafeGrammar.TokensMember (..),
    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.Data.HFList        as HFList
import qualified Language.Parser.Ptera.Syntax             as Syntax
import qualified Language.Parser.Ptera.Syntax.Grammar             as SyntaxGrammar
import qualified Language.Parser.Ptera.Syntax.SafeGrammar as SafeGrammar
import           Language.Parser.Ptera.TH.ParserLib
import qualified Language.Parser.Ptera.TH.Class.LiftType as LiftType
import qualified Language.Parser.Ptera.Data.HEnum     as HEnum
import qualified Type.Membership as Membership


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 ()

data TypedExpr rules tokens elem us = TypedExpr
    { TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr :: SafeGrammar.Expr rules tokens elem us
    , TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr :: HFList.T TTypeQ us
    }

newtype TTypeQ a = TTypeQ (TH.Q TH.Type)


eps :: TypedExpr rules tokens elem '[]
eps :: TypedExpr rules tokens elem '[]
eps = TypedExpr :: forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> T TTypeQ us -> TypedExpr rules tokens elem us
TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[]
unTypedExpr = Expr IntermNonTerminal Terminal elem '[]
-> Expr rules tokens elem '[]
forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr Expr IntermNonTerminal Terminal elem '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[]
getTypesOfExpr = T TTypeQ '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    }

(<^>)
    :: TypedExpr rules tokens elem us1 -> TypedExpr rules tokens elem us2
    -> TypedExpr rules tokens elem (HFList.Concat us1 us2)
TypedExpr rules tokens elem us1
e1 <^> :: TypedExpr rules tokens elem us1
-> TypedExpr rules tokens elem us2
-> TypedExpr rules tokens elem (Concat us1 us2)
<^> TypedExpr rules tokens elem us2
e2 = TypedExpr :: forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> T TTypeQ us -> TypedExpr rules tokens elem us
TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem (Concat us1 us2)
unTypedExpr = Expr IntermNonTerminal Terminal elem (Concat us1 us2)
-> Expr rules tokens elem (Concat us1 us2)
forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr
        do HFList (Unit IntermNonTerminal Terminal elem) us1
-> HFList (Unit IntermNonTerminal Terminal elem) us2
-> Expr IntermNonTerminal Terminal elem (Concat us1 us2)
forall k (f :: k -> *) (xs1 :: [k]) (xs2 :: [k]).
HFList f xs1 -> HFList f xs2 -> HFList f (Concat xs1 xs2)
HFList.hconcat
            do Expr rules tokens elem us1
-> HFList (Unit IntermNonTerminal Terminal elem) us1
forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> Expr IntermNonTerminal Terminal elem us
SafeGrammar.unsafeExpr do TypedExpr rules tokens elem us1 -> Expr rules tokens elem us1
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr rules tokens elem us1
e1
            do Expr rules tokens elem us2
-> HFList (Unit IntermNonTerminal Terminal elem) us2
forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> Expr IntermNonTerminal Terminal elem us
SafeGrammar.unsafeExpr do TypedExpr rules tokens elem us2 -> Expr rules tokens elem us2
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr rules tokens elem us2
e2
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ (Concat us1 us2)
getTypesOfExpr = HFList TTypeQ us1 -> HFList TTypeQ us2 -> T TTypeQ (Concat us1 us2)
forall k (f :: k -> *) (xs1 :: [k]) (xs2 :: [k]).
HFList f xs1 -> HFList f xs2 -> HFList f (Concat xs1 xs2)
HFList.hconcat
        do TypedExpr rules tokens elem us1 -> HFList TTypeQ us1
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr TypedExpr rules tokens elem us1
e1
        do TypedExpr rules tokens elem us2 -> HFList TTypeQ us2
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr TypedExpr rules tokens elem us2
e2
    }

infixr 5 <^>


(<:>)
    :: LiftType.T ctx
    => LiftType.T a
    => TypedExpr rules tokens elem us
    -> (HTExpList us -> TH.Q (TH.TExp a))
    -> AltM ctx rules tokens elem a
TypedExpr rules tokens elem us
e <:> :: TypedExpr rules tokens elem us
-> (HTExpList us -> Q (TExp a)) -> AltM ctx rules tokens elem a
<:> HTExpList us -> Q (TExp a)
act = TypedExpr rules tokens elem us -> Expr rules tokens elem us
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr 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)) -> T TTypeQ us -> SemActM ctx us a
forall ctx a (us :: [*]).
(T ctx, T a) =>
(HTExpList us -> Q (TExp a)) -> T TTypeQ us -> SemActM ctx us a
semAct HTExpList us -> Q (TExp a)
act do TypedExpr rules tokens elem us -> T TTypeQ us
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr TypedExpr rules tokens elem us
e

infixl 4 <:>

(<::>)
    :: LiftType.T ctx
    => LiftType.T a
    => TypedExpr rules tokens elem us
    -> (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a)))
    -> AltM ctx rules tokens elem a
TypedExpr rules tokens elem us
e <::> :: TypedExpr 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 = TypedExpr rules tokens elem us -> Expr rules tokens elem us
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr 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)))
-> T TTypeQ us -> SemActM ctx us a
forall ctx (us :: [*]) a.
(T ctx, T a) =>
(HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T TTypeQ us -> SemActM ctx us a
semActM HTExpList us -> Q (TExp (ActionTask ctx a))
act do TypedExpr rules tokens elem us -> T TTypeQ us
forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr TypedExpr rules tokens elem us
e

infixl 4 <::>


var :: forall v rules tokens elem proxy1 proxy2 a.
    KnownSymbol v => a ~ SafeGrammar.RuleExprReturnType rules v => LiftType.T a =>
    proxy1 rules -> proxy2 v -> TypedExpr rules tokens elem '[a]
var :: proxy1 rules -> proxy2 v -> TypedExpr rules tokens elem '[a]
var proxy1 rules
_ proxy2 v
pv = TypedExpr :: forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> T TTypeQ us -> TypedExpr rules tokens elem us
TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[a]
unTypedExpr = Expr IntermNonTerminal Terminal elem '[a]
-> Expr rules tokens elem '[a]
forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr do Unit IntermNonTerminal Terminal elem a
-> HFList (Unit IntermNonTerminal Terminal elem) '[]
-> Expr IntermNonTerminal Terminal elem '[a]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons Unit IntermNonTerminal Terminal elem a
u HFList (Unit IntermNonTerminal Terminal elem) '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[a]
getTypesOfExpr = TTypeQ a -> T TTypeQ '[] -> T TTypeQ '[a]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons TTypeQ a
tq T TTypeQ '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    } where
        u :: Unit IntermNonTerminal Terminal elem a
u = IntermNonTerminal -> Unit IntermNonTerminal Terminal elem a
forall k nonTerminal terminal (elem :: k) (u :: k).
nonTerminal -> Unit nonTerminal terminal elem u
SyntaxGrammar.UnitVar do proxy2 v -> IntermNonTerminal
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> IntermNonTerminal
symbolVal proxy2 v
pv
        tq :: TTypeQ a
tq = Q Type -> TTypeQ a
forall k (a :: k). Q Type -> TTypeQ a
TTypeQ do Proxy a -> Q Type
forall k (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do Proxy a
forall k (t :: k). Proxy t
Proxy @a

varA :: forall v rules tokens elem a.
    KnownSymbol v => a ~ SafeGrammar.RuleExprReturnType rules v => LiftType.T a =>
    TypedExpr rules tokens elem '[a]
varA :: TypedExpr rules tokens elem '[a]
varA = Proxy rules -> Proxy v -> TypedExpr rules tokens elem '[a]
forall (v :: Symbol) rules tokens elem (proxy1 :: * -> *)
       (proxy2 :: Symbol -> *) a.
(KnownSymbol v, a ~ RuleExprReturnType rules v, T a) =>
proxy1 rules -> proxy2 v -> TypedExpr rules tokens elem '[a]
var
    do Proxy rules
forall k (t :: k). Proxy t
Proxy @rules
    do Proxy v
forall k (t :: k). Proxy t
Proxy @v

tok :: forall t rules tokens elem proxy. LiftType.T elem
    => proxy elem -> Membership.Membership (SafeGrammar.TokensTag tokens) t
    -> TypedExpr rules tokens elem '[elem]
tok :: proxy elem
-> Membership (TokensTag tokens) t
-> TypedExpr rules tokens elem '[elem]
tok proxy elem
pe Membership (TokensTag tokens) t
pm = TypedExpr :: forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> T TTypeQ us -> TypedExpr rules tokens elem us
TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[elem]
unTypedExpr = Expr IntermNonTerminal Terminal elem '[elem]
-> Expr rules tokens elem '[elem]
forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr do Unit IntermNonTerminal Terminal elem elem
-> HFList (Unit IntermNonTerminal Terminal elem) '[]
-> Expr IntermNonTerminal Terminal elem '[elem]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons Unit IntermNonTerminal Terminal elem elem
u HFList (Unit IntermNonTerminal Terminal elem) '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[elem]
getTypesOfExpr = TTypeQ elem -> T TTypeQ '[] -> T TTypeQ '[elem]
forall k (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons TTypeQ elem
tq T TTypeQ '[]
forall k (a :: k -> *). HFList a '[]
HFList.HFNil
    } where
        u :: Unit IntermNonTerminal Terminal elem elem
u = Terminal -> Unit IntermNonTerminal Terminal elem elem
forall k terminal nonTerminal (elem :: k).
terminal -> Unit nonTerminal terminal elem elem
SyntaxGrammar.UnitToken
            do HEnum (TokensTag tokens) -> Terminal
forall k (as :: [k]). HEnum as -> Terminal
HEnum.unsafeHEnum do Membership (TokensTag tokens) t -> HEnum (TokensTag tokens)
forall k (a :: k) (as :: [k]). Membership as a -> HEnum as
HEnum.henum Membership (TokensTag tokens) t
pm
        tq :: TTypeQ elem
tq = Q Type -> TTypeQ elem
forall k (a :: k). Q Type -> TTypeQ a
TTypeQ do proxy elem -> Q Type
forall k (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType proxy elem
pe

tokA :: forall t rules tokens elem.
    LiftType.T elem => SafeGrammar.TokensMember tokens t =>
    TypedExpr rules tokens elem '[elem]
tokA :: TypedExpr rules tokens elem '[elem]
tokA = Proxy elem
-> Membership (TokensTag tokens) t
-> TypedExpr rules tokens elem '[elem]
forall (t :: Symbol) rules tokens elem (proxy :: * -> *).
T elem =>
proxy elem
-> Membership (TokensTag tokens) t
-> TypedExpr rules tokens elem '[elem]
tok
    do Proxy elem
forall k (t :: k). Proxy t
Proxy @elem
    do Proxy# '(tokens, t) -> Membership (TokensTag tokens) t
forall tokens (t :: Symbol).
TokensMember tokens t =>
Proxy# '(tokens, t) -> Membership (TokensTag tokens) t
SafeGrammar.tokensMembership do Proxy# '(tokens, t)
forall k (a :: k). Proxy# a
proxy# @'(tokens, t)


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

{-# COMPLETE HNil #-}

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 :*

{-# COMPLETE (:*) #-}


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 :: forall ctx us a
    .  LiftType.T ctx
    => LiftType.T a
    => (HTExpList us -> TH.Q (TH.TExp (ActionTask ctx a)))
    -> HFList.T TTypeQ us -> SemActM ctx us a
semActM :: (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T TTypeQ us -> SemActM ctx us a
semActM HTExpList us -> Q (TExp (ActionTask ctx a))
f T TTypeQ 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 TTypeQ us -> Q ([Name], HTExpList us)
forall (args :: [*]). T TTypeQ args -> Q ([Name], HTExpList args)
actArgs T TTypeQ us
xs0
        Name
l <- IntermNonTerminal -> Q Name
TH.newName IntermNonTerminal
"pteraTHSemActArgs"
        let tqA :: Q Type
tqA = Proxy a -> Q Type
forall k (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do Proxy a
forall k (t :: k). Proxy t
Proxy @a
        let tqCtx :: Q Type
tqCtx = Proxy ctx -> Q Type
forall k (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do Proxy ctx
forall k (t :: k). Proxy t
Proxy @ctx
        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) :: ActionTask $(tqCtx) $(tqA)
            _ ->
                error "unreachable: unexpected arguments"
            |]

    actArgs :: HFList.T TTypeQ args -> TH.Q ([TH.Name], HTExpList args)
    actArgs :: T TTypeQ args -> Q ([Name], HTExpList args)
actArgs = \case
        T TTypeQ args
HFList.HFNil ->
            ([Name], HTExpList '[]) -> Q ([Name], HTExpList '[])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], HTExpList '[]
HNil)
        HFList.HFCons (TTypeQ Q Type
t) HFList TTypeQ xs
xs -> do
            Name
n <- IntermNonTerminal -> Q Name
TH.newName IntermNonTerminal
"pteraTHSemActArg"
            let e :: Q Exp
e = 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 = Q Exp -> Q (TExp x)
forall a. Q Exp -> Q (TExp a)
TH.unsafeTExpCoerce
                    [|pteraTHUnsafeExtractReduceArgument $(e) :: $(t)|]
            ([Name]
ns, HTExpList xs
args) <- HFList TTypeQ xs -> Q ([Name], HTExpList xs)
forall (args :: [*]). T TTypeQ args -> Q ([Name], HTExpList args)
actArgs HFList TTypeQ 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
    :: LiftType.T ctx
    => LiftType.T a
    => (HTExpList us -> TH.Q (TH.TExp a))
    -> HFList.T TTypeQ us -> SemActM ctx us a
semAct :: (HTExpList us -> Q (TExp a)) -> T TTypeQ us -> SemActM ctx us a
semAct HTExpList us -> Q (TExp a)
f = (HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T TTypeQ us -> SemActM ctx us a
forall ctx (us :: [*]) a.
(T ctx, T a) =>
(HTExpList us -> Q (TExp (ActionTask ctx a)))
-> T TTypeQ us -> SemActM ctx us a
semActM do \HTExpList us
us -> [||pteraTHActionTaskPure $$(f us)||]