{-# LANGUAGE TemplateHaskell #-}

module Language.Parser.Ptera.TH.Util (
    genGrammarToken,
    GenRulesTypes (..),
    genRules,
    genParsePoints,
    module Language.Parser.Ptera.Data.HEnum,
    unsafeMembership,
) where

import           Language.Parser.Ptera.Prelude

import qualified Language.Haskell.TH              as TH
import qualified Language.Haskell.TH.Syntax       as TH
import           Language.Parser.Ptera.Data.HEnum (HEnum (..))
import           Language.Parser.Ptera.TH.Syntax
import           Prelude                          (String)
import qualified Type.Membership                  as Membership
import qualified Unsafe.Coerce                    as Unsafe

genGrammarToken :: TH.Name -> TH.Q TH.Type -> [(String, TH.Q TH.Pat)] -> TH.Q [TH.Dec]
genGrammarToken :: Name -> Q Type -> [(String, Q Pat)] -> Q [Dec]
genGrammarToken Name
tyName Q Type
tokenTy [(String, Q Pat)]
tokens = do
    Dec
grammarTokenInstD <- Q Dec
grammarTokenInstDQ
    Dec
tokensTagInstD <- Q Dec
tokensTagInstDQ
    [Dec]
tokensMemberInstDs <- Q [Dec]
tokensMemberInstDsQ
    [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure do [Dec
tokensTyD, Dec
grammarTokenInstD, Dec
tokensTagInstD] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
tokensMemberInstDs
    where
        tokensTyD :: Dec
tokensTyD = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
tyName [] Maybe Type
forall a. Maybe a
Nothing [] []

        grammarTokenInstDQ :: Q Dec
grammarTokenInstDQ = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD Maybe Overlap
forall a. Maybe a
Nothing []
            (Type -> [Dec] -> Dec) -> Q Type -> Q ([Dec] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|GrammarToken $(pure do TH.ConT tyName) $(tokenTy)|]
            Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ Name -> [Clause] -> Dec
TH.FunD
                    do String -> Name
TH.mkName String
"tokenToTerminal"
                    ([Clause] -> Dec) -> Q [Clause] -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Clause] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Clause
tokenToTerminalClause]
                ]

        tokensTagInstDQ :: Q Dec
tokensTagInstDQ = TySynEqn -> Dec
TH.TySynInstD
            (TySynEqn -> Dec) -> Q TySynEqn -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TH.TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing
                    (Type -> Type -> TySynEqn) -> Q Type -> Q (Type -> TySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|TokensTag $(tokensTy)|]
                    Q (Type -> TySynEqn) -> Q Type -> Q TySynEqn
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((String, Q Pat) -> Q Type -> Q Type)
-> Q Type -> [(String, Q Pat)] -> Q Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                        do \(String
tokenName, Q Pat
_) Q Type
ty -> do
                            let tokenLitTy :: Type
tokenLitTy = TyLit -> Type
TH.LitT do String -> TyLit
TH.StrTyLit String
tokenName
                            [t|$(pure tokenLitTy) ': $(ty)|]
                        do [t|'[]|]
                        do [(String, Q Pat)]
tokens

        tokensMemberInstDsQ :: Q [Dec]
tokensMemberInstDsQ = Int -> [Dec] -> [(String, Q Pat)] -> Q [Dec]
buildTokensMemberInstDsQ
            do Int
0 :: Int
            do []
            do [(String, Q Pat)]
tokens

        tokenToTerminalClause :: Q Clause
tokenToTerminalClause = do
            Name
paramTokenName <- String -> Q Name
TH.newName String
"token"
            [Pat] -> Body -> [Dec] -> Clause
TH.Clause
                ([Pat] -> Body -> [Dec] -> Clause)
-> Q [Pat] -> Q (Body -> [Dec] -> Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q [Pat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[p|Proxy|], Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Pat
TH.VarP Name
paramTokenName]
                Q (Body -> [Dec] -> Clause) -> Q Body -> Q ([Dec] -> Clause)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> do Exp -> Body
TH.NormalB (Exp -> Body) -> ([Match] -> Exp) -> [Match] -> Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> [Match] -> Exp
TH.CaseE
                        do Name -> Exp
TH.VarE Name
paramTokenName
                        ([Match] -> Body) -> Q [Match] -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> [Match] -> [(String, Q Pat)] -> Q [Match]
forall t a.
(Lift t, Num t) =>
t -> [Match] -> [(a, Q Pat)] -> Q [Match]
buildTokenToTerminalMatchesQ
                            do Int
0 :: Int
                            do []
                            do [(String, Q Pat)]
tokens
                Q ([Dec] -> Clause) -> Q [Dec] -> Q Clause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        buildTokensMemberInstDsQ :: Int -> [Dec] -> [(String, Q Pat)] -> Q [Dec]
buildTokensMemberInstDsQ Int
n [Dec]
ds = \case
            [] ->
                [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
ds
            (String
tokenName, Q Pat
_):[(String, Q Pat)]
ts -> do
                let tokenLitTy :: Type
tokenLitTy = TyLit -> Type
TH.LitT do String -> TyLit
TH.StrTyLit String
tokenName
                [Dec]
tokenDs <- [d|
                    instance TokensMember $(tokensTy) $(pure tokenLitTy) where
                        tokensMembership _ = unsafeMembership $(TH.lift n)
                    |]
                Int -> [Dec] -> [(String, Q Pat)] -> Q [Dec]
buildTokensMemberInstDsQ
                    do Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                    do [Dec]
tokenDs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ds
                    do [(String, Q Pat)]
ts

        buildTokenToTerminalMatchesQ :: t -> [Match] -> [(a, Q Pat)] -> Q [Match]
buildTokenToTerminalMatchesQ t
n [Match]
ms = \case
            [] ->
                [Match] -> Q [Match]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Match]
ms
            (a
_, Q Pat
tokenPat):[(a, Q Pat)]
ts -> do
                Match
m <- Pat -> Body -> [Dec] -> Match
TH.Match
                    (Pat -> Body -> [Dec] -> Match)
-> Q Pat -> Q (Body -> [Dec] -> Match)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Pat
tokenPat
                    Q (Body -> [Dec] -> Match) -> Q Body -> Q ([Dec] -> Match)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> do Exp -> Body
TH.NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                            [e|UnsafeHEnum $(TH.lift n)|]
                    Q ([Dec] -> Match) -> Q [Dec] -> Q Match
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                t -> [Match] -> [(a, Q Pat)] -> Q [Match]
buildTokenToTerminalMatchesQ
                    do t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1
                    do Match
mMatch -> [Match] -> [Match]
forall a. a -> [a] -> [a]
:[Match]
ms
                    do [(a, Q Pat)]
ts

        tokensTy :: Q Type
tokensTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
tyName

data GenRulesTypes = GenRulesTypes
    { GenRulesTypes -> Q Type
genRulesCtxTy    :: TH.Q TH.Type
    , GenRulesTypes -> Q Type
genRulesTokensTy :: TH.Q TH.Type
    , GenRulesTypes -> Q Type
genRulesTokenTy  :: TH.Q TH.Type
    }

genRules :: TH.Name -> GenRulesTypes -> [(TH.Name, String, TH.Q TH.Type)] -> TH.Q [TH.Dec]
genRules :: Name -> GenRulesTypes -> [(Name, String, Q Type)] -> Q [Dec]
genRules Name
rulesTyName GenRulesTypes
genRulesTypes [(Name, String, Q Type)]
ruleDefs
    = (:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
rulesTyD Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        do (:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
rulesTagInstD Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
            do (:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
ruleExprTypeTyD Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                do [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
rulesInstD Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
hasFieldDs
    where
        rulesTyD :: Q Dec
rulesTyD = Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
rulesTyName [] Maybe Type
forall a. Maybe a
Nothing
            ([Con] -> [DerivClause] -> Dec)
-> Q [Con] -> Q ([DerivClause] -> Dec)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Con] -> Q [Con]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ Name -> [VarBangType] -> Con
TH.RecC Name
rulesTyName
                    ([VarBangType] -> Con) -> Q [VarBangType] -> Q Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType] -> [(Name, String, Q Type)] -> Q [VarBangType]
buildRuleFields [] [(Name, String, Q Type)]
ruleDefs
                ]
            Q ([DerivClause] -> Dec) -> Q [DerivClause] -> Q Dec
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [DerivClause] -> Q [DerivClause]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        rulesTagInstD :: Q Dec
rulesTagInstD = TySynEqn -> Dec
TH.TySynInstD
            (TySynEqn -> Dec) -> Q TySynEqn -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TH.TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing
                    (Type -> Type -> TySynEqn) -> Q Type -> Q (Type -> TySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|RulesTag $(rulesTy)|]
                    Q (Type -> TySynEqn) -> Q Type -> Q TySynEqn
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type -> [(Name, String, Q Type)] -> Q Type
forall a c. Q Type -> [(a, String, c)] -> Q Type
buildNonTerminalSymList [t|'[]|] [(Name, String, Q Type)]
ruleDefs

        rulesInstD :: Q [Dec]
rulesInstD =
            [d|
            instance Rules $(rulesTy) where
                generateRules =
                    $(foldl'
                        do \l _ -> [|HFCons DictF $(l)|]
                        do [|HFNil|]
                        ruleDefs
                    )
            |]

        ruleExprTypeTyD :: Q Dec
ruleExprTypeTyD = TySynEqn -> Dec
TH.TySynInstD
            (TySynEqn -> Dec) -> Q TySynEqn -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TH.TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing
                    (Type -> Type -> TySynEqn) -> Q Type -> Q (Type -> TySynEqn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|RuleExprType $(rulesTy)|]
                    Q (Type -> TySynEqn) -> Q Type -> Q TySynEqn
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Type
ruleExprTy

        hasFieldDs :: Q [Dec]
hasFieldDs = [Dec] -> [(Name, String, Q Type)] -> Q [Dec]
buildHasFieldInstances [] [(Name, String, Q Type)]
ruleDefs

        buildRuleFields :: [VarBangType] -> [(Name, String, Q Type)] -> Q [VarBangType]
buildRuleFields [VarBangType]
acc = \case
            [] ->
                [VarBangType] -> Q [VarBangType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [VarBangType]
acc
            (Name
fieldName, String
_, Q Type
ty):[(Name, String, Q Type)]
rs -> do
                Type
fieldTy <- [t|$(ruleExprTy) $(ty)|]
                [VarBangType] -> [(Name, String, Q Type)] -> Q [VarBangType]
buildRuleFields
                    do (Name
fieldName, Bang
fieldBang, Type
fieldTy)VarBangType -> [VarBangType] -> [VarBangType]
forall a. a -> [a] -> [a]
:[VarBangType]
acc
                    do [(Name, String, Q Type)]
rs

        buildNonTerminalSymList :: Q Type -> [(a, String, c)] -> Q Type
buildNonTerminalSymList Q Type
acc = \case
            [] ->
                Q Type
acc
            (a
_, String
name, c
_):[(a, String, c)]
rs -> do
                let nameTy :: Type
nameTy = TyLit -> Type
TH.LitT do String -> TyLit
TH.StrTyLit String
name
                Q Type -> [(a, String, c)] -> Q Type
buildNonTerminalSymList
                    [t|$(pure nameTy) ': $(acc)|] [(a, String, c)]
rs

        buildHasFieldInstances :: [Dec] -> [(Name, String, Q Type)] -> Q [Dec]
buildHasFieldInstances [Dec]
acc = \case
            [] ->
                [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
acc
            (Name
fieldName, String
name, Q Type
ty):[(Name, String, Q Type)]
rs -> do
                let nameTy :: Q Type
nameTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do TyLit -> Type
TH.LitT do String -> TyLit
TH.StrTyLit String
name
                [Dec]
insts <-
                    [d|
                    instance HasRuleExprField $(rulesTy) $(nameTy) where
                        type RuleExprReturnType $(rulesTy) $(nameTy) = $(ty)

                        getExprField x _ = $(pure do TH.VarE fieldName) x
                    |]
                [Dec] -> [(Name, String, Q Type)] -> Q [Dec]
buildHasFieldInstances
                    do [Dec]
insts [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
acc
                    do [(Name, String, Q Type)]
rs

        fieldBang :: Bang
fieldBang = SourceUnpackedness -> SourceStrictness -> Bang
TH.Bang
            SourceUnpackedness
TH.NoSourceUnpackedness
            SourceStrictness
TH.SourceStrict

        rulesTy :: Q Type
rulesTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
rulesTyName

        ruleExprTy :: Q Type
ruleExprTy =
            [t|RuleExprM
                $(genRulesCtxTy genRulesTypes)
                $(rulesTy)
                $(genRulesTokensTy genRulesTypes)
                $(genRulesTokenTy genRulesTypes)
            |]

genParsePoints :: TH.Name -> TH.Name -> [String] -> TH.Q [TH.Dec]
genParsePoints :: Name -> Name -> [String] -> Q [Dec]
genParsePoints Name
tyName Name
rulesTyName [String]
initials = (:) (Dec -> [Dec] -> [Dec]) -> Q Dec -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
parsePointsTyD Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q [Dec]
memberInitialsInstD where
    parsePointsTyD :: Q Dec
parsePointsTyD = Name -> [TyVarBndr] -> Type -> Dec
TH.TySynD Name
tyName [] (Type -> Dec) -> Q Type -> Q Dec
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Q Type
buildParsePointsSymList [String]
initials

    memberInitialsInstD :: Q [Dec]
memberInitialsInstD =
        [d|
        instance MemberInitials $(rulesTy) $(parsePointsTy) where
            memberInitials =
                $(foldl'
                    do \l _ -> [|HFCons DictF $(l)|]
                    do [|HFNil|]
                    do initials
                )
        |]

    buildParsePointsSymList :: [String] -> Q Type
buildParsePointsSymList = \case
        [] ->
            [t|'[]|]
        String
n:[String]
ns -> do
            let nameTy :: Type
nameTy = TyLit -> Type
TH.LitT do String -> TyLit
TH.StrTyLit String
n
            [t|$(pure nameTy) ': $(buildParsePointsSymList ns)|]

    parsePointsTy :: Q Type
parsePointsTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
tyName

    rulesTy :: Q Type
rulesTy = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
rulesTyName

unsafeMembership :: Int -> Membership.Membership xs x
unsafeMembership :: Int -> Membership xs x
unsafeMembership = Int -> Membership xs x
forall a b. a -> b
Unsafe.unsafeCoerce