{-# 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure do [Dec
tokensTyD, Dec
grammarTokenInstD, Dec
tokensTagInstD] forall a. [a] -> [a] -> [a]
++ [Dec]
tokensMemberInstDs
    where
        tokensTyD :: Dec
tokensTyD = Cxt
-> Name
-> [TyVarBndr ()]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD [] Name
tyName [] forall a. Maybe a
Nothing [] []

        grammarTokenInstDQ :: Q Dec
grammarTokenInstDQ = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
TH.InstanceD forall a. Maybe a
Nothing []
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|GrammarToken $(pure do TH.ConT tyName) $(tokenTy)|]
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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"
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TH.TySynEqn forall a. Maybe a
Nothing
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|TokensTag $(tokensTy)|]
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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 <- forall (m :: * -> *). Quote m => String -> m Name
TH.newName String
"token"
            [Pat] -> Body -> [Dec] -> Clause
TH.Clause
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[p|Proxy|], forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Pat
TH.VarP Name
paramTokenName]
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> do Exp -> Body
TH.NormalB forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Exp -> [Match] -> Exp
TH.CaseE
                        do Name -> Exp
TH.VarE Name
paramTokenName
                        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {t} {a}.
(Quote f, Lift t, Num t) =>
t -> [Match] -> [(a, f Pat)] -> f [Match]
buildTokenToTerminalMatchesQ
                            do Int
0 :: Int
                            do []
                            do [(String, Q Pat)]
tokens
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        buildTokensMemberInstDsQ :: Int -> [Dec] -> [(String, Q Pat)] -> Q [Dec]
buildTokensMemberInstDsQ Int
n [Dec]
ds = \case
            [] ->
                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 forall a. Num a => a -> a -> a
+ Int
1
                    do [Dec]
tokenDs forall a. [a] -> [a] -> [a]
++ [Dec]
ds
                    do [(String, Q Pat)]
ts

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

        tokensTy :: Q Type
tokensTy = 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
    = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
rulesTyD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
        do (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
rulesTagInstD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
            do (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
ruleExprTypeTyD forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
                do forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Dec]
rulesInstD 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 [] forall a. Maybe a
Nothing
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
                [ Name -> [VarBangType] -> Con
TH.RecC Name
rulesTyName
                    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
                ]
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

        rulesTagInstD :: Q Dec
rulesTagInstD = TySynEqn -> Dec
TH.TySynInstD
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TH.TySynEqn forall a. Maybe a
Nothing
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|RulesTag $(rulesTy)|]
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {m :: * -> *} {a} {c}.
Quote m =>
m Type -> [(a, String, c)] -> m 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
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TH.TySynEqn forall a. Maybe a
Nothing
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|RuleExprType $(rulesTy)|]
                    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
            [] ->
                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)forall a. a -> [a] -> [a]
:[VarBangType]
acc
                    do [(Name, String, Q Type)]
rs

        buildNonTerminalSymList :: m Type -> [(a, String, c)] -> m Type
buildNonTerminalSymList m Type
acc = \case
            [] ->
                m 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
                m Type -> [(a, String, c)] -> m Type
buildNonTerminalSymList
                    [t|$(pure nameTy) ': $(acc)|] [(a, String, c)]
rs

        buildHasFieldInstances :: [Dec] -> [(Name, String, Q Type)] -> Q [Dec]
buildHasFieldInstances [Dec]
acc = \case
            [] ->
                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 = 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 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 = 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 = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Dec
parsePointsTyD 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 [] 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure do Name -> Type
TH.ConT Name
tyName

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

unsafeMembership :: Int -> Membership.Membership xs x
unsafeMembership :: forall {k} (xs :: [k]) (x :: k). Int -> Membership xs x
unsafeMembership = forall a b. a -> b
Unsafe.unsafeCoerce