{-# LANGUAGE UndecidableInstances #-}

module Language.Parser.Ptera.TH.Pipeline.Grammar2ParserDec where

import           Language.Parser.Ptera.Prelude

import qualified Language.Haskell.TH                             as TH
import qualified Language.Parser.Ptera.Pipeline.SafeGrammar2SRB  as SafeGrammar2SRB
import qualified Language.Parser.Ptera.TH.Pipeline.SRB2ParserDec as SRB2ParserDec
import qualified Language.Parser.Ptera.TH.Syntax                 as Syntax
import qualified Type.Membership                                 as Membership

grammar2ParserDec
    :: forall initials rules tokens ctx elem
    .  Syntax.GrammarToken tokens elem
    => Membership.Generate (Syntax.TokensTag tokens)
    => PipelineParam
    -> Syntax.GrammarM ctx rules tokens elem initials
    -> TH.Q [TH.Dec]
grammar2ParserDec :: PipelineParam -> GrammarM ctx rules tokens elem initials -> Q [Dec]
grammar2ParserDec PipelineParam
param GrammarM ctx rules tokens elem initials
g = do
    T Int StringLit (Maybe ()) (Action (SemActM ctx))
srb <- case GrammarM ctx rules tokens elem initials
-> Either
     [StringLit] (T Int StringLit (Maybe ()) (Action (SemActM ctx)))
forall (action :: [*] -> * -> *) rules tokens elem
       (initials :: [Symbol]).
T action rules tokens elem initials
-> Either [StringLit] (T Int StringLit (Maybe ()) (Action action))
SafeGrammar2SRB.safeGrammar2Srb GrammarM ctx rules tokens elem initials
g of
        Right T Int StringLit (Maybe ()) (Action (SemActM ctx))
x -> T Int StringLit (Maybe ()) (Action (SemActM ctx))
-> Q (T Int StringLit (Maybe ()) (Action (SemActM ctx)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure T Int StringLit (Maybe ()) (Action (SemActM ctx))
x
        Left [StringLit]
vs -> do
            let errorMsg :: StringLit
errorMsg = StringLit
"Failed to generate parser.  "
                    StringLit -> StringLit -> StringLit
forall a. Semigroup a => a -> a -> a
<> StringLit
"Detect left recursions at " StringLit -> StringLit -> StringLit
forall a. Semigroup a => a -> a -> a
<> [StringLit] -> StringLit
forall a. Show a => a -> StringLit
show [StringLit]
vs StringLit -> StringLit -> StringLit
forall a. Semigroup a => a -> a -> a
<> StringLit
"."
            StringLit -> Q (T Int StringLit (Maybe ()) (Action (SemActM ctx)))
forall (m :: * -> *) a. MonadFail m => StringLit -> m a
fail StringLit
errorMsg
    PipelineParam
-> T Int StringLit (Maybe ()) (Action (SemActM ctx)) -> Q [Dec]
forall altDoc ctx.
PipelineParam
-> T Int StringLit (Maybe altDoc) (SemanticAction ctx) -> Q [Dec]
SRB2ParserDec.srb2QParser
        do PipelineParam :: Q Type
-> Q Type
-> Q Type
-> Q Type
-> Q Type
-> (Int, Int)
-> PipelineParam
SRB2ParserDec.PipelineParam
            {
                $sel:startsTy:PipelineParam :: Q Type
startsTy = PipelineParam -> Q Type
startsTy PipelineParam
param,
                $sel:rulesTy:PipelineParam :: Q Type
rulesTy = PipelineParam -> Q Type
rulesTy PipelineParam
param,
                $sel:tokensTy:PipelineParam :: Q Type
tokensTy = PipelineParam -> Q Type
tokensTy PipelineParam
param,
                $sel:tokenTy:PipelineParam :: Q Type
tokenTy = PipelineParam -> Q Type
tokenTy PipelineParam
param,
                $sel:customCtxTy:PipelineParam :: Q Type
customCtxTy = PipelineParam -> Q Type
customCtxTy PipelineParam
param,
                $sel:tokenBounds:PipelineParam :: (Int, Int)
tokenBounds =
                    ( Int
0
                    , Proxy (TokensTag tokens) -> Int
forall k (xs :: [k]) (proxy :: [k] -> *).
Generate xs =>
proxy xs -> Int
Membership.hcount do Proxy (TokensTag tokens)
forall k (t :: k). Proxy t
Proxy @(Syntax.TokensTag tokens)
                    )
            }
        do T Int StringLit (Maybe ()) (Action (SemActM ctx))
srb

data PipelineParam = PipelineParam
    {
        PipelineParam -> Q Type
startsTy    :: TH.Q TH.Type,
        PipelineParam -> Q Type
rulesTy     :: TH.Q TH.Type,
        PipelineParam -> Q Type
tokensTy    :: TH.Q TH.Type,
        PipelineParam -> Q Type
tokenTy     :: TH.Q TH.Type,
        PipelineParam -> Q Type
customCtxTy :: TH.Q TH.Type
    }