{-# 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 (:*),
    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
    { forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr :: SafeGrammar.Expr rules tokens elem us
    , forall 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 :: forall rules tokens elem. TypedExpr rules tokens elem '[]
eps = TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[]
unTypedExpr = forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr forall {k} (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[]
getTypesOfExpr = 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 <^> :: forall rules tokens elem (us1 :: [*]) (us2 :: [*]).
TypedExpr rules tokens elem us1
-> TypedExpr rules tokens elem us2
-> TypedExpr rules tokens elem (Concat us1 us2)
<^> TypedExpr rules tokens elem us2
e2 = TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem (Concat us1 us2)
unTypedExpr = forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr
        do forall {k} (f :: k -> *) (xs1 :: [k]) (xs2 :: [k]).
HFList f xs1 -> HFList f xs2 -> HFList f (Concat xs1 xs2)
HFList.hconcat
            do forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> Expr IntermNonTerminal Terminal elem us
SafeGrammar.unsafeExpr do forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr rules tokens elem us1
e1
            do forall rules tokens elem (us :: [*]).
Expr rules tokens elem us
-> Expr IntermNonTerminal Terminal elem us
SafeGrammar.unsafeExpr do 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 = forall {k} (f :: k -> *) (xs1 :: [k]) (xs2 :: [k]).
HFList f xs1 -> HFList f xs2 -> HFList f (Concat xs1 xs2)
HFList.hconcat
        do forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> T TTypeQ us
getTypesOfExpr TypedExpr rules tokens elem us1
e1
        do 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.Code TH.Q a)
    -> AltM ctx rules tokens elem a
TypedExpr rules tokens elem us
e <:> :: forall ctx a rules tokens elem (us :: [*]).
(T ctx, T a) =>
TypedExpr rules tokens elem us
-> (HTExpList us -> Code Q a) -> AltM ctx rules tokens elem a
<:> HTExpList us -> Code Q a
act = forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr rules tokens elem us
e forall rules tokens elem (us :: [*]) (action :: [*] -> * -> *) a.
Expr rules tokens elem us
-> action us a -> Alt action rules tokens elem a
SafeGrammar.<:> forall ctx a (us :: [*]).
(T ctx, T a) =>
(HTExpList us -> Code Q a) -> T TTypeQ us -> SemActM ctx us a
semAct HTExpList us -> Code Q a
act do 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.Code TH.Q (ActionTask ctx a))
    -> AltM ctx rules tokens elem a
TypedExpr rules tokens elem us
e <::> :: forall ctx a rules tokens elem (us :: [*]).
(T ctx, T a) =>
TypedExpr rules tokens elem us
-> (HTExpList us -> Code Q (ActionTask ctx a))
-> AltM ctx rules tokens elem a
<::> HTExpList us -> Code Q (ActionTask ctx a)
act = forall rules tokens elem (us :: [*]).
TypedExpr rules tokens elem us -> Expr rules tokens elem us
unTypedExpr TypedExpr rules tokens elem us
e forall rules tokens elem (us :: [*]) (action :: [*] -> * -> *) a.
Expr rules tokens elem us
-> action us a -> Alt action rules tokens elem a
SafeGrammar.<:> forall ctx (us :: [*]) a.
(T ctx, T a) =>
(HTExpList us -> Code Q (ActionTask ctx a))
-> T TTypeQ us -> SemActM ctx us a
semActM HTExpList us -> Code Q (ActionTask ctx a)
act do 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 :: 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 proxy1 rules
_ proxy2 v
pv = TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[a]
unTypedExpr = forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr do 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 forall {k} (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[a]
getTypesOfExpr = forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons TTypeQ a
tq forall {k} (a :: k -> *). HFList a '[]
HFList.HFNil
    } where
        u :: Unit IntermNonTerminal Terminal elem a
u = forall {k} nonTerminal terminal (elem :: k) (u :: k).
nonTerminal -> Unit nonTerminal terminal elem u
SyntaxGrammar.UnitVar do forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> IntermNonTerminal
symbolVal proxy2 v
pv
        tq :: TTypeQ a
tq = forall {k} (a :: k). Q Type -> TTypeQ a
TTypeQ do forall {k} (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do 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 :: forall (v :: Symbol) rules tokens elem a.
(KnownSymbol v, a ~ RuleExprReturnType rules v, T a) =>
TypedExpr rules tokens elem '[a]
varA = 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 forall {k} (t :: k). Proxy t
Proxy @rules
    do 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 :: forall (t :: Symbol) rules tokens elem (proxy :: * -> *).
T elem =>
proxy elem
-> Membership (TokensTag tokens) t
-> TypedExpr rules tokens elem '[elem]
tok proxy elem
pe Membership (TokensTag tokens) t
pm = TypedExpr
    { $sel:unTypedExpr:TypedExpr :: Expr rules tokens elem '[elem]
unTypedExpr = forall rules tokens elem (us :: [*]).
Expr IntermNonTerminal Terminal elem us
-> Expr rules tokens elem us
SafeGrammar.UnsafeExpr do 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 forall {k} (a :: k -> *). HFList a '[]
HFList.HFNil
    , $sel:getTypesOfExpr:TypedExpr :: T TTypeQ '[elem]
getTypesOfExpr = forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> HFList a xs -> HFList a (x : xs)
HFList.HFCons TTypeQ elem
tq forall {k} (a :: k -> *). HFList a '[]
HFList.HFNil
    } where
        u :: Unit IntermNonTerminal Terminal elem elem
u = forall {k} terminal nonTerminal (elem :: k).
terminal -> Unit nonTerminal terminal elem elem
SyntaxGrammar.UnitToken
            do forall k (as :: [k]). HEnum as -> Terminal
HEnum.unsafeHEnum do forall {k} (a :: k) (as :: [k]). Membership as a -> HEnum as
HEnum.henum Membership (TokensTag tokens) t
pm
        tq :: TTypeQ elem
tq = forall {k} (a :: k). Q Type -> TTypeQ a
TTypeQ do 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 :: forall (t :: Symbol) rules tokens elem.
(T elem, TokensMember tokens t) =>
TypedExpr rules tokens elem '[elem]
tokA = forall (t :: Symbol) rules tokens elem (proxy :: * -> *).
T elem =>
proxy elem
-> Membership (TokensTag tokens) t
-> TypedExpr rules tokens elem '[elem]
tok
    do forall {k} (t :: k). Proxy t
Proxy @elem
    do forall tokens (t :: Symbol).
TokensMember tokens t =>
Proxy# '(tokens, t) -> Membership (TokensTag tokens) t
SafeGrammar.tokensMembership do forall {k} (a :: k). Proxy# a
proxy# @'(tokens, t)


type HTExpList = HFList.T (TH.Code TH.Q)

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

{-# COMPLETE HNil #-}

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

infixr 6 :*

{-# COMPLETE (:*) #-}


type SemActM :: Type -> [Type] -> Type -> Type
newtype SemActM ctx us a = UnsafeSemActM
    { forall ctx (us :: [*]) a. 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.Code TH.Q (ActionTask ctx a))
    -> HFList.T TTypeQ us -> SemActM ctx us a
semActM :: forall ctx (us :: [*]) a.
(T ctx, T a) =>
(HTExpList us -> Code Q (ActionTask ctx a))
-> T TTypeQ us -> SemActM ctx us a
semActM HTExpList us -> Code Q (ActionTask ctx a)
f T TTypeQ us
xs0 = 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) <- forall (args :: [*]). T TTypeQ args -> Q ([Name], HTExpList args)
actArgs T TTypeQ us
xs0
        Name
l <- forall (m :: * -> *). Quote m => IntermNonTerminal -> m Name
TH.newName IntermNonTerminal
"pteraTHSemActArgs"
        let tqA :: Q Type
tqA = forall {k} (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do forall {k} (t :: k). Proxy t
Proxy @a
        let tqCtx :: Q Type
tqCtx = forall {k} (a :: k) (proxy :: k -> *).
LiftType a =>
proxy a -> Q Type
LiftType.liftType do forall {k} (t :: k). Proxy t
Proxy @ctx
        let lp :: Q Pat
lp = forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Pat
TH.VarP Name
l
        let le :: Q Exp
le = forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Exp
TH.VarE Name
l
        let lp0 :: Q Pat
lp0 = 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.unTypeCode do f args) :: ActionTask $(tqCtx) $(tqA)
            _ ->
                error "unreachable: unexpected arguments"
            |]

    actArgs :: HFList.T TTypeQ args -> TH.Q ([TH.Name], HTExpList args)
    actArgs :: forall (args :: [*]). T TTypeQ args -> Q ([Name], HTExpList args)
actArgs = \case
        T TTypeQ args
HFList.HFNil ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], HTExpList '[]
HNil)
        HFList.HFCons (TTypeQ Q Type
t) HFList TTypeQ xs
xs -> do
            Name
n <- forall (m :: * -> *). Quote m => IntermNonTerminal -> m Name
TH.newName IntermNonTerminal
"pteraTHSemActArg"
            let e :: Q Exp
e = forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Exp
TH.VarE Name
n
            let arg :: Code Q x
arg = forall a (m :: * -> *). Quote m => m Exp -> Code m a
TH.unsafeCodeCoerce
                    [|pteraTHUnsafeExtractReduceArgument $(e) :: $(t)|]
            ([Name]
ns, HTExpList xs
args) <- forall (args :: [*]). T TTypeQ args -> Q ([Name], HTExpList args)
actArgs HFList TTypeQ xs
xs
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
nforall a. a -> [a] -> [a]
:[Name]
ns, Code Q x
arg forall u (us :: [*]).
Code Q u -> HTExpList us -> HTExpList (u : us)
:* HTExpList xs
args)

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