module Language.Parser.Ptera.Pipeline.Grammar2PEG where import Language.Parser.Ptera.Prelude import qualified Data.EnumMap.Strict as EnumMap import qualified Language.Parser.Ptera.Data.HFList as HFList 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 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 :: forall start nonTerminal terminal elem varDoc altDoc (action :: [*] -> * -> *). (Enum start, Enum nonTerminal, Enum terminal) => FixedGrammar start nonTerminal terminal elem varDoc altDoc action -> T start varDoc altDoc (Action action) grammar2Peg FixedGrammar start nonTerminal terminal elem varDoc altDoc action g = forall a. Identity a -> a runIdentity do forall (m :: * -> *) start varDoc altDoc a. Monad m => BuilderT start varDoc altDoc a m () -> m (T start varDoc altDoc a) PEGBuilder.build StateT (Context start varDoc altDoc (Action action)) Identity () builder where builder :: StateT (Context start varDoc altDoc (Action action)) Identity () builder = do Context start varDoc altDoc (Action action) initialBuilderCtx <- forall (m :: * -> *) s. Monad m => StateT s m s get let initialCtx :: Context start nonTerminal varDoc altDoc action initialCtx = 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 = forall k a. EnumMap k a EnumMap.empty , $sel:ctxDisplayNonTerminals:Context :: EnumMap nonTerminal varDoc ctxDisplayNonTerminals = forall {k1} {k2} start nonTerminal terminal (elem :: k1) varDoc altDoc (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 = forall s a. State s a -> s -> s execState StateT (Context start nonTerminal varDoc altDoc action) Identity () pipeline Context start nonTerminal varDoc altDoc action initialCtx forall (m :: * -> *) s. Monad m => s -> StateT s m () put do 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 :: StateT (Context start nonTerminal varDoc altDoc action) Identity () pipeline = do forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ do forall k a. Enum k => EnumMap k a -> [(k, a)] EnumMap.assocs do forall {k1} {k2} start nonTerminal terminal (elem :: k1) varDoc altDoc (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) -> forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). (Enum start, Enum nonTerminal) => start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () grammarStartPipeline start s nonTerminal v forall (t :: * -> *) (m :: * -> *) a b. (Foldable t, Monad m) => t a -> (a -> m b) -> m () forM_ do forall k a. Enum k => EnumMap k a -> [(k, a)] EnumMap.assocs do forall {k1} {k2} start nonTerminal terminal (elem :: k1) varDoc altDoc (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) -> 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 { forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> Context start varDoc altDoc (Action action) ctxBuilder :: PEGBuilder.Context start varDoc altDoc (Grammar.Action action) , forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap :: EnumMap.EnumMap nonTerminal PEG.VarNum , forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). 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 :: forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). (Enum start, Enum nonTerminal) => start -> nonTerminal -> Pipeline start nonTerminal varDoc altDoc action () grammarStartPipeline start s nonTerminal v = do VarNum newV <- forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do 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 :: 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 (Grammar.RuleExpr [Alt nonTerminal terminal elem altDoc action a] alts) = do VarNum newV <- forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v [AltNum] newAlts <- 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 -> 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 forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do 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 :: 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 (Grammar.Alt Expr nonTerminal terminal elem us e altDoc d action us r act) = do [Unit] newUs <- 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 = forall (action :: [*] -> * -> *) (us :: [*]) a. action us a -> Action action Grammar.Action action us r act let newAlt :: Alt altDoc (Action action) newAlt = 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 } forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do 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 :: 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 = do [Unit] revUs <- 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 <- 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 forall (f :: * -> *) a. Applicative f => a -> f a pure do Unit newUforall a. a -> [a] -> [a] :[Unit] acc do Expr nonTerminal terminal elem us e forall (f :: * -> *) a. Applicative f => a -> f a pure do 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 :: 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 = \case Grammar.UnitToken terminal t -> forall (f :: * -> *) a. Applicative f => a -> f a pure do Terminal -> Unit PEG.UnitTerminal do forall a. Enum a => a -> Terminal fromEnum terminal t Grammar.UnitVar nonTerminal v -> do VarNum newV <- forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v 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 :: forall nonTerminal start varDoc altDoc (action :: [*] -> * -> *). Enum nonTerminal => nonTerminal -> Pipeline start nonTerminal varDoc altDoc action VarNum getNewVar nonTerminal v = do EnumMap nonTerminal VarNum vmap <- forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) s. Monad m => StateT s m s get case forall k a. Enum k => k -> EnumMap k a -> Maybe a EnumMap.lookup nonTerminal v EnumMap nonTerminal VarNum vmap of Just VarNum newV -> forall (f :: * -> *) a. Applicative f => a -> f a pure VarNum newV Maybe VarNum Nothing -> do EnumMap nonTerminal varDoc displayNonTerminals <- forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal varDoc ctxDisplayNonTerminals forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (m :: * -> *) s. Monad m => StateT s m s get let d :: varDoc d = case 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 -> forall a. HasCallStack => [Char] -> a error [Char] "Not found any rules for a non-terminal." VarNum newV <- forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. T start varDoc altDoc (Action action) Identity r -> Pipeline start nonTerminal varDoc altDoc action r liftBuilder do forall (m :: * -> *) varDoc start altDoc a. Monad m => Var varDoc -> BuilderT start varDoc altDoc a m VarNum PEGBuilder.genNewVar do PEG.Var { $sel:varHelp:Var :: varDoc varHelp = varDoc d } 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 = forall k a. Enum k => k -> a -> EnumMap k a -> EnumMap k a EnumMap.insert nonTerminal v VarNum newV do forall start nonTerminal varDoc altDoc (action :: [*] -> * -> *). Context start nonTerminal varDoc altDoc action -> EnumMap nonTerminal VarNum ctxVarMap Context start nonTerminal varDoc altDoc action ctx } 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 :: forall start varDoc altDoc (action :: [*] -> * -> *) r nonTerminal. 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 <- forall (m :: * -> *) s. Monad m => StateT s m s get let (r x, Context start varDoc altDoc (Action action) builderCtx) = forall s a. State s a -> s -> (a, s) runState T start varDoc altDoc (Action action) Identity r builder do 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 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 } forall (f :: * -> *) a. Applicative f => a -> f a pure r x