module Language.Parser.Ptera.Pipeline.Grammar2PEG where import Language.Parser.Ptera.Prelude import qualified Data.EnumMap.Strict as EnumMap import qualified Language.Parser.Ptera.Machine.PEG as PEG import qualified Language.Parser.Ptera.Machine.PEG.Builder as PEGBuilder import qualified Language.Parser.Ptera.Syntax.Grammar as Grammar import qualified Language.Parser.Ptera.Data.HFList as HFList grammar2Peg :: Enum start => Enum nonTerminal => Enum terminal => Grammar.FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> PEG.T start varDoc altDoc (Grammar.Action action) grammar2Peg :: FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> T start varDoc altDoc (Action action) grammar2Peg FixedGrammar start nonTerminal terminal elem varDoc altDoc action g = Identity (T start varDoc altDoc (Action action)) -> T start varDoc altDoc (Action action) forall a. Identity a -> a runIdentity do BuilderT start varDoc altDoc (Action action) Identity () -> Identity (T start varDoc altDoc (Action action)) forall (m :: * -> *) start varDoc altDoc a. Monad m => BuilderT start varDoc altDoc a m () -> m (T start varDoc altDoc a) PEGBuilder.build BuilderT start varDoc altDoc (Action action) Identity () builder where builder :: BuilderT start varDoc altDoc (Action action) Identity () builder = do Context start varDoc altDoc (Action action) initialBuilderCtx <- StateT (Context start varDoc altDoc (Action action)) Identity (Context start varDoc altDoc (Action action)) forall (m :: * -> *) s. Monad m => StateT s m s get let initialCtx :: Context start nonTerminal varDoc altDoc action initialCtx = Context :: forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start varDoc altDoc (Action action) -> EnumMap nonTerminal VarNum -> EnumMap nonTerminal varDoc -> Context start nonTerminal varDoc altDoc action Context { $sel:ctxBuilder:Context :: Context start varDoc altDoc (Action action) ctxBuilder = Context start varDoc altDoc (Action action) initialBuilderCtx , $sel:ctxVarMap:Context :: EnumMap nonTerminal VarNum ctxVarMap = EnumMap nonTerminal VarNum forall k a. EnumMap k a EnumMap.empty , $sel:ctxDisplayNonTerminals:Context :: EnumMap nonTerminal varDoc ctxDisplayNonTerminals = FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap nonTerminal varDoc forall start nonTerminal terminal k1 (elem :: k1) varDoc altDoc k2 (action :: [k1] -> k2 -> *). FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap nonTerminal varDoc Grammar.grammarDisplayNonTerminals FixedGrammar start nonTerminal terminal elem varDoc altDoc action g } let finalCtx :: Context start nonTerminal varDoc altDoc action finalCtx = State (Context start nonTerminal varDoc altDoc action) () -> Context start nonTerminal varDoc altDoc action -> Context start nonTerminal varDoc altDoc action forall s a. State s a -> s -> s execState State (Context start nonTerminal varDoc altDoc action) () pipeline Context start nonTerminal varDoc altDoc action initialCtx Context start varDoc altDoc (Action action) -> BuilderT start varDoc altDoc (Action action) Identity () forall (m :: * -> *) s. Monad m => s -> StateT s m () put do Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) ctxBuilder Context start nonTerminal varDoc altDoc action finalCtx pipeline :: State (Context start nonTerminal varDoc altDoc action) () pipeline = do [(start, nonTerminal)] -> ((start, nonTerminal) -> State (Context start nonTerminal varDoc altDoc action) ()) -> State (Context start nonTerminal varDoc altDoc action) () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ do EnumMap start nonTerminal -> [(start, nonTerminal)] forall k a. Enum k => EnumMap k a -> [(k, a)] EnumMap.assocs do FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap start nonTerminal forall start nonTerminal terminal k1 (elem :: k1) varDoc altDoc k2 (action :: [k1] -> k2 -> *). FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap start nonTerminal Grammar.grammarStarts FixedGrammar start nonTerminal terminal elem varDoc altDoc action g do \(start s, nonTerminal v) -> start -> nonTerminal -> State (Context start nonTerminal varDoc altDoc action) () forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). (Enum start, Enum nonTerminal) => start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () grammarStartPipeline start s nonTerminal v [(nonTerminal, RuleExpr nonTerminal terminal elem altDoc action)] -> ((nonTerminal, RuleExpr nonTerminal terminal elem altDoc action) -> State (Context start nonTerminal varDoc altDoc action) ()) -> State (Context start nonTerminal varDoc altDoc action) () forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ do EnumMap nonTerminal (RuleExpr nonTerminal terminal elem altDoc action) -> [(nonTerminal, RuleExpr nonTerminal terminal elem altDoc action)] forall k a. Enum k => EnumMap k a -> [(k, a)] EnumMap.assocs do FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap nonTerminal (RuleExpr nonTerminal terminal elem altDoc action) forall start nonTerminal terminal k1 (elem :: k1) varDoc altDoc k2 (action :: [k1] -> k2 -> *). FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> EnumMap nonTerminal (RuleExpr nonTerminal terminal elem altDoc action) Grammar.grammarRules FixedGrammar start nonTerminal terminal elem varDoc altDoc action g do \(nonTerminal v, RuleExpr nonTerminal terminal elem altDoc action e) -> nonTerminal -> RuleExpr nonTerminal terminal elem altDoc action -> State (Context start nonTerminal varDoc altDoc action) () forall nonTerminal terminal elem altDoc (action :: [*] -> * -> *) start varDoc. (Enum nonTerminal, Enum terminal) => nonTerminal -> RuleExpr nonTerminal terminal elem altDoc action -> Pipeline start nonTerminal varDoc altDoc action () grammarRulePipeline nonTerminal v RuleExpr nonTerminal terminal elem altDoc action e type Pipeline start nonTerminal varDoc altDoc action = State (Context start nonTerminal varDoc altDoc action) data Context start nonTerminal varDoc altDoc action = Context { Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) ctxBuilder :: PEGBuilder.Context start varDoc altDoc (Grammar.Action action) , Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap :: EnumMap.EnumMap nonTerminal PEG.VarNum , Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal varDoc ctxDisplayNonTerminals :: EnumMap.EnumMap nonTerminal varDoc } grammarStartPipeline :: Enum start => Enum nonTerminal => start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () grammarStartPipeline :: start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () grammarStartPipeline start s nonTerminal v = do VarNum newV <- nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v T start varDoc altDoc (Action action) Identity () -> Pipeline start nonTerminal varDoc altDoc action () forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do start -> VarNum -> T start varDoc altDoc (Action action) Identity () forall (m :: * -> *) start varDoc altDoc a. (Monad m, Enum start) => start -> VarNum -> BuilderT start varDoc altDoc a m () PEGBuilder.addInitial start s VarNum newV grammarRulePipeline :: Enum nonTerminal => Enum terminal => nonTerminal -> Grammar.RuleExpr nonTerminal terminal elem altDoc action -> Pipeline start nonTerminal varDoc altDoc action () grammarRulePipeline :: nonTerminal -> RuleExpr nonTerminal terminal elem altDoc action -> Pipeline start nonTerminal varDoc altDoc action () grammarRulePipeline nonTerminal v (Grammar.RuleExpr [Alt nonTerminal terminal elem altDoc action a] alts) = do VarNum newV <- nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v [AltNum] newAlts <- [Alt nonTerminal terminal elem altDoc action a] -> (Alt nonTerminal terminal elem altDoc action a -> StateT (Context start nonTerminal varDoc altDoc action) Identity AltNum) -> StateT (Context start nonTerminal varDoc altDoc action) Identity [AltNum] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) forM [Alt nonTerminal terminal elem altDoc action a] alts \Alt nonTerminal terminal elem altDoc action a alt -> Alt nonTerminal terminal elem altDoc action a -> StateT (Context start nonTerminal varDoc altDoc action) Identity AltNum forall nonTerminal terminal elem altDoc (action :: [*] -> * -> *) r start varDoc. (Enum nonTerminal, Enum terminal) => Alt nonTerminal terminal elem altDoc action r -> Pipeline start nonTerminal varDoc altDoc action AltNum grammarAltPipeline Alt nonTerminal terminal elem altDoc action a alt let newRule :: Rule newRule = [AltNum] -> Rule PEG.Rule [AltNum] newAlts T start varDoc altDoc (Action action) Identity () -> Pipeline start nonTerminal varDoc altDoc action () forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do VarNum -> Rule -> T start varDoc altDoc (Action action) Identity () forall (m :: * -> *) start varDoc altDoc a. Monad m => VarNum -> Rule -> BuilderT start varDoc altDoc a m () PEGBuilder.addRule VarNum newV Rule newRule grammarAltPipeline :: Enum nonTerminal => Enum terminal => Grammar.Alt nonTerminal terminal elem altDoc action r -> Pipeline start nonTerminal varDoc altDoc action PEG.AltNum grammarAltPipeline :: Alt nonTerminal terminal elem altDoc action r -> Pipeline start nonTerminal varDoc altDoc action AltNum grammarAltPipeline (Grammar.Alt Expr nonTerminal terminal elem us e altDoc d action us r act) = do [Unit] newUs <- Expr nonTerminal terminal elem us -> Pipeline start nonTerminal varDoc altDoc action [Unit] forall k start nonTerminal terminal (elem :: k) varDoc altDoc (action :: [*] -> * -> *) (us :: [k]). (Enum nonTerminal, Enum terminal) => Expr nonTerminal terminal elem us -> Pipeline start nonTerminal varDoc altDoc action [Unit] grammarExprPipeline Expr nonTerminal terminal elem us e let newAct :: Action action newAct = action us r -> Action action forall (action :: [*] -> * -> *) (us :: [*]) a. action us a -> Action action Grammar.Action action us r act let newAlt :: Alt altDoc (Action action) newAlt = Alt :: forall altDoc a. AltKind -> [Unit] -> a -> altDoc -> Alt altDoc a PEG.Alt { $sel:altKind:Alt :: AltKind altKind = AltKind PEG.AltSeq , $sel:altUnitSeq:Alt :: [Unit] altUnitSeq = [Unit] newUs , $sel:altAction:Alt :: Action action altAction = Action action newAct , $sel:altHelp:Alt :: altDoc altHelp = altDoc d } T start varDoc altDoc (Action action) Identity AltNum -> Pipeline start nonTerminal varDoc altDoc action AltNum forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do Alt altDoc (Action action) -> T start varDoc altDoc (Action action) Identity AltNum forall (m :: * -> *) altDoc a start varDoc. Monad m => Alt altDoc a -> BuilderT start varDoc altDoc a m AltNum PEGBuilder.genNewAlt Alt altDoc (Action action) newAlt grammarExprPipeline :: forall start nonTerminal terminal elem varDoc altDoc action us . Enum nonTerminal => Enum terminal => Grammar.Expr nonTerminal terminal elem us -> Pipeline start nonTerminal varDoc altDoc action [PEG.Unit] grammarExprPipeline :: Expr nonTerminal terminal elem us -> Pipeline start nonTerminal varDoc altDoc action [Unit] grammarExprPipeline Expr nonTerminal terminal elem us e = do [Unit] revUs <- [Unit] -> (forall (x :: k). [Unit] -> Membership us x -> Unit nonTerminal terminal elem x -> Pipeline start nonTerminal varDoc altDoc action [Unit]) -> Expr nonTerminal terminal elem us -> Pipeline start nonTerminal varDoc altDoc action [Unit] forall k (m :: * -> *) r (f :: k -> *) (xs :: [k]). Monad m => r -> (forall (x :: k). r -> Membership xs x -> f x -> m r) -> HFList f xs -> m r HFList.hfoldMWithIndex [] do \[Unit] acc Membership us x _ Unit nonTerminal terminal elem x u -> do Unit newU <- Unit nonTerminal terminal elem x -> Pipeline start nonTerminal varDoc altDoc action Unit forall k nonTerminal terminal (elem :: k) (u :: k) start varDoc altDoc (action :: [*] -> * -> *). (Enum nonTerminal, Enum terminal) => Unit nonTerminal terminal elem u -> Pipeline start nonTerminal varDoc altDoc action Unit grammarUnitPipeline Unit nonTerminal terminal elem x u [Unit] -> Pipeline start nonTerminal varDoc altDoc action [Unit] forall (f :: * -> *) a. Applicative f => a -> f a pure do Unit newUUnit -> [Unit] -> [Unit] forall a. a -> [a] -> [a] :[Unit] acc do Expr nonTerminal terminal elem us e [Unit] -> Pipeline start nonTerminal varDoc altDoc action [Unit] forall (f :: * -> *) a. Applicative f => a -> f a pure do [Unit] -> [Unit] forall a. [a] -> [a] reverse [Unit] revUs grammarUnitPipeline :: Enum nonTerminal => Enum terminal => Grammar.Unit nonTerminal terminal elem u -> Pipeline start nonTerminal varDoc altDoc action PEG.Unit grammarUnitPipeline :: Unit nonTerminal terminal elem u -> Pipeline start nonTerminal varDoc altDoc action Unit grammarUnitPipeline = \case Grammar.UnitToken terminal t -> Unit -> Pipeline start nonTerminal varDoc altDoc action Unit forall (f :: * -> *) a. Applicative f => a -> f a pure do Terminal -> Unit PEG.UnitTerminal do terminal -> Terminal forall a. Enum a => a -> Terminal fromEnum terminal t Grammar.UnitVar nonTerminal v -> do VarNum newV <- nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v Unit -> Pipeline start nonTerminal varDoc altDoc action Unit forall (f :: * -> *) a. Applicative f => a -> f a pure do VarNum -> Unit PEG.UnitNonTerminal VarNum newV getNewVar :: Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action PEG.VarNum getNewVar :: nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v = do EnumMap nonTerminal VarNum vmap <- Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap (Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum) -> StateT (Context start nonTerminal varDoc altDoc action) Identity (Context start nonTerminal varDoc altDoc action) -> StateT (Context start nonTerminal varDoc altDoc action) Identity (EnumMap nonTerminal VarNum) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StateT (Context start nonTerminal varDoc altDoc action) Identity (Context start nonTerminal varDoc altDoc action) forall (m :: * -> *) s. Monad m => StateT s m s get case nonTerminal -> EnumMap nonTerminal VarNum -> Maybe VarNum forall k a. Enum k => k -> EnumMap k a -> Maybe a EnumMap.lookup nonTerminal v EnumMap nonTerminal VarNum vmap of Just VarNum newV -> VarNum -> Pipeline start nonTerminal varDoc altDoc action VarNum forall (f :: * -> *) a. Applicative f => a -> f a pure VarNum newV Maybe VarNum Nothing -> do EnumMap nonTerminal varDoc displayNonTerminals <- Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal varDoc forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal varDoc ctxDisplayNonTerminals (Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal varDoc) -> StateT (Context start nonTerminal varDoc altDoc action) Identity (Context start nonTerminal varDoc altDoc action) -> StateT (Context start nonTerminal varDoc altDoc action) Identity (EnumMap nonTerminal varDoc) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StateT (Context start nonTerminal varDoc altDoc action) Identity (Context start nonTerminal varDoc altDoc action) forall (m :: * -> *) s. Monad m => StateT s m s get let d :: varDoc d = case nonTerminal -> EnumMap nonTerminal varDoc -> Maybe varDoc forall k a. Enum k => k -> EnumMap k a -> Maybe a EnumMap.lookup nonTerminal v EnumMap nonTerminal varDoc displayNonTerminals of Just varDoc x -> varDoc x Maybe varDoc Nothing -> [Char] -> varDoc forall a. HasCallStack => [Char] -> a error [Char] "Not found any rules for a non-terminal." VarNum newV <- T start varDoc altDoc (Action action) Identity VarNum -> Pipeline start nonTerminal varDoc altDoc action VarNum forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do Var varDoc -> T start varDoc altDoc (Action action) Identity VarNum forall (m :: * -> *) varDoc start altDoc a. Monad m => Var varDoc -> BuilderT start varDoc altDoc a m VarNum PEGBuilder.genNewVar do Var :: forall varDoc. varDoc -> Var varDoc PEG.Var { $sel:varHelp:Var :: varDoc varHelp = varDoc d } (Context start nonTerminal varDoc altDoc action -> Context start nonTerminal varDoc altDoc action) -> StateT (Context start nonTerminal varDoc altDoc action) Identity () forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m () modify' \Context start nonTerminal varDoc altDoc action ctx -> Context start nonTerminal varDoc altDoc action ctx { $sel:ctxVarMap:Context :: EnumMap nonTerminal VarNum ctxVarMap = nonTerminal -> VarNum -> EnumMap nonTerminal VarNum -> EnumMap nonTerminal VarNum forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a EnumMap.insert nonTerminal v VarNum newV do Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap Context start nonTerminal varDoc altDoc action ctx } VarNum -> Pipeline start nonTerminal varDoc altDoc action VarNum forall (f :: * -> *) a. Applicative f => a -> f a pure VarNum newV liftBuilder :: PEGBuilder.T start varDoc altDoc (Grammar.Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder :: T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder T start varDoc altDoc (Action action) Identity r builder = do Context start nonTerminal varDoc altDoc action ctx <- StateT (Context start nonTerminal varDoc altDoc action) Identity (Context start nonTerminal varDoc altDoc action) forall (m :: * -> *) s. Monad m => StateT s m s get let (r x, Context start varDoc altDoc (Action action) builderCtx) = T start varDoc altDoc (Action action) Identity r -> Context start varDoc altDoc (Action action) -> (r, Context start varDoc altDoc (Action action)) forall s a. State s a -> s -> (a, s) runState T start varDoc altDoc (Action action) Identity r builder do Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) ctxBuilder Context start nonTerminal varDoc altDoc action ctx Context start nonTerminal varDoc altDoc action -> StateT (Context start nonTerminal varDoc altDoc action) Identity () forall (m :: * -> *) s. Monad m => s -> StateT s m () put do Context start nonTerminal varDoc altDoc action ctx { $sel:ctxBuilder:Context :: Context start varDoc altDoc (Action action) ctxBuilder = Context start varDoc altDoc (Action action) builderCtx } r -> Pipeline start nonTerminal varDoc altDoc action r forall (f :: * -> *) a. Applicative f => a -> f a pure r x