module Language.Parser.Ptera.Pipeline.PEG2LAPEG where

import           Language.Parser.Ptera.Prelude

import qualified Data.EnumMap.Strict                         as EnumMap
import qualified Language.Parser.Ptera.Data.Alignable.Array  as AlignableArray
import qualified Language.Parser.Ptera.Data.Alignable.Map    as AlignableMap
import qualified Language.Parser.Ptera.Data.Alignable.Set    as AlignableSet
import qualified Language.Parser.Ptera.Data.Symbolic.IntSet  as SymbolicIntSet
import qualified Language.Parser.Ptera.Machine.LAPEG         as LAPEG
import qualified Language.Parser.Ptera.Machine.LAPEG.Builder as LAPEGBuilder
import qualified Language.Parser.Ptera.Machine.PEG           as PEG


peg2LaPeg :: Enum start
    => PEG.T start varDoc altDoc a
    -> Except (AlignableSet.T PEG.VarNum) (LAPEG.T start varDoc altDoc a)
peg2LaPeg :: forall start varDoc altDoc a.
Enum start =>
T start varDoc altDoc a
-> Except (T VarNum) (T start varDoc altDoc a)
peg2LaPeg T start varDoc altDoc a
g = forall (m :: * -> *) start varDoc altDoc a.
Monad m =>
BuilderT start varDoc altDoc a m () -> m (T start varDoc altDoc a)
LAPEGBuilder.build StateT
  (Context start varDoc altDoc a) (ExceptT (T VarNum) Identity) ()
builder where
    builder :: StateT
  (Context start varDoc altDoc a) (ExceptT (T VarNum) Identity) ()
builder = do
        Context start varDoc altDoc a
initialCtxBuilder <- forall (m :: * -> *) s. Monad m => StateT s m s
get
        let initialCtx :: Context start varDoc altDoc a
initialCtx = Context
                { $sel:ctxBuilder:Context :: Context start varDoc altDoc a
ctxBuilder = Context start varDoc altDoc a
initialCtxBuilder
                , $sel:ctxVarMap:Context :: T VarNum VarNum
ctxVarMap = forall {k} (n :: k) a. Map n a
AlignableMap.empty
                , $sel:ctxAvailableRuleRanges:Context :: T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges = forall {k} (n :: k) a. Map n a
AlignableMap.empty
                , $sel:ctxUpdateRuleStack:Context :: [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack = []
                , $sel:ctxOriginalVars:Context :: T VarNum (Var varDoc)
ctxOriginalVars = forall start varDoc altDoc a.
PEG start varDoc altDoc a -> T VarNum (Var varDoc)
PEG.vars T start varDoc altDoc a
g
                , $sel:ctxOriginalRules:Context :: T VarNum Rule
ctxOriginalRules = forall start varDoc altDoc a.
PEG start varDoc altDoc a -> T VarNum Rule
PEG.rules T start varDoc altDoc a
g
                , $sel:ctxOriginalAlts:Context :: T AltNum (Alt altDoc a)
ctxOriginalAlts = forall start varDoc altDoc a.
PEG start varDoc altDoc a -> T AltNum (Alt altDoc a)
PEG.alts T start varDoc altDoc a
g
                }
        let (Either (T VarNum) ()
mx, Context start varDoc altDoc a
finalCtx) = forall s a. State s a -> s -> (a, s)
runState
                do forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do forall {start} {varDoc} {altDoc} {a}.
Enum start =>
EnumMap start VarNum
-> ExceptT (T VarNum) (State (Context start varDoc altDoc a)) ()
pipeline do forall start varDoc altDoc a.
PEG start varDoc altDoc a -> EnumMap start VarNum
PEG.initials T start varDoc altDoc a
g
                do Context start varDoc altDoc a
initialCtx
        case Either (T VarNum) ()
mx of
            Left T VarNum
vs -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE T VarNum
vs
            Right{} -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put do forall start varDoc altDoc a.
Context start varDoc altDoc a -> Context start varDoc altDoc a
ctxBuilder Context start varDoc altDoc a
finalCtx

    pipeline :: EnumMap start VarNum
-> ExceptT (T VarNum) (State (Context start varDoc altDoc a)) ()
pipeline EnumMap start VarNum
inits = do
        T VarNum
rvs <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM
            do \T VarNum
vs1 (start
s, VarNum
v) -> forall (m :: * -> *) e a e'.
Monad m =>
ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE
                do
                    forall start varDoc altDoc a.
Enum start =>
start -> VarNum -> Pipeline start varDoc altDoc a ()
pegInitialPipeline start
s VarNum
v
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure T VarNum
vs1
                \T VarNum
vs2 -> do
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
                        forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx
                            { $sel:ctxAvailableRuleRanges:Context :: T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges = forall {k} (n :: k) a. Map n a
AlignableMap.empty
                            , $sel:ctxUpdateRuleStack:Context :: [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack = []
                            }
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure do forall {k} (n :: k). Set n -> Set n -> Set n
AlignableSet.union T VarNum
vs1 T VarNum
vs2
            do forall {k} (n :: k). Set n
AlignableSet.empty
            do forall k a. Enum k => EnumMap k a -> [(k, a)]
EnumMap.assocs EnumMap start VarNum
inits
        if forall {k} (n :: k). Set n -> Bool
AlignableSet.null T VarNum
rvs
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            else forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE T VarNum
rvs

type Pipeline start varDoc altDoc a =
    ExceptT (AlignableSet.T PEG.VarNum) (State (Context start varDoc altDoc a))

data Context start varDoc altDoc a = Context
    { forall start varDoc altDoc a.
Context start varDoc altDoc a -> Context start varDoc altDoc a
ctxBuilder        :: LAPEGBuilder.Context start varDoc altDoc a
    , forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum VarNum
ctxVarMap         :: AlignableMap.T PEG.VarNum LAPEG.VarNum
    , forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges     :: AlignableMap.T LAPEG.VarNum (Maybe LAPEG.HeadRange)
    , forall start varDoc altDoc a.
Context start varDoc altDoc a
-> [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack :: [(LAPEG.VarNum, LAPEG.HeadRange, [PEG.Alt altDoc a])]
    , forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Var varDoc)
ctxOriginalVars :: AlignableArray.T PEG.VarNum (PEG.Var varDoc)
    , forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum Rule
ctxOriginalRules  :: AlignableArray.T PEG.VarNum PEG.Rule
    , forall start varDoc altDoc a.
Context start varDoc altDoc a -> T AltNum (Alt altDoc a)
ctxOriginalAlts  :: AlignableArray.T PEG.AltNum (PEG.Alt altDoc a)
    }

pegInitialPipeline :: Enum start
    => start -> PEG.VarNum -> Pipeline start varDoc altDoc a ()
pegInitialPipeline :: forall start varDoc altDoc a.
Enum start =>
start -> VarNum -> Pipeline start varDoc altDoc a ()
pegInitialPipeline start
s VarNum
v = do
    VarNum
newV <- forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a (Maybe VarNum)
getAvailableVar VarNum
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just VarNum
x ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure VarNum
x
        Maybe VarNum
Nothing -> do
            (VarNum
x, HeadRange
_) <- forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a (VarNum, HeadRange)
pegVarPipeline VarNum
v
            forall (f :: * -> *) a. Applicative f => a -> f a
pure VarNum
x
    forall start varDoc altDoc a. Pipeline start varDoc altDoc a ()
pegRuleStackPipeline
    forall start varDoc altDoc a r.
T start varDoc altDoc a Identity r
-> Pipeline start varDoc altDoc a r
liftBuilder do forall (m :: * -> *) start varDoc altDoc a.
(Monad m, Enum start) =>
start -> VarNum -> BuilderT start varDoc altDoc a m ()
LAPEGBuilder.addInitial start
s VarNum
newV

pegRuleStackPipeline :: Pipeline start varDoc altDoc a ()
pegRuleStackPipeline :: forall start varDoc altDoc a. Pipeline start varDoc altDoc a ()
pegRuleStackPipeline = forall start varDoc altDoc a.
Pipeline
  start varDoc altDoc a (Maybe (VarNum, HeadRange, [Alt altDoc a]))
popUpdateRuleItem forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (VarNum, HeadRange, [Alt altDoc a])
Nothing ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (VarNum
newV, HeadRange
newRange, [Alt altDoc a]
rule) -> do
        forall altDoc a start varDoc.
VarNum
-> HeadRange -> [Alt altDoc a] -> Pipeline start varDoc altDoc a ()
pegRulePipeline VarNum
newV HeadRange
newRange [Alt altDoc a]
rule
        forall start varDoc altDoc a. Pipeline start varDoc altDoc a ()
pegRuleStackPipeline

pegVarPipeline
    :: PEG.VarNum -> Pipeline start varDoc altDoc a (LAPEG.VarNum, LAPEG.HeadRange)
pegVarPipeline :: forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a (VarNum, HeadRange)
pegVarPipeline VarNum
v = do
    VarNum
newV <- forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a VarNum
getNewVar VarNum
v
    T VarNum (Maybe HeadRange)
availableRuleRanges <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges
    case forall n a. T n => n -> Map n a -> Maybe a
AlignableMap.lookup VarNum
newV T VarNum (Maybe HeadRange)
availableRuleRanges of
        Maybe (Maybe HeadRange)
Nothing ->
            VarNum -> Pipeline start varDoc altDoc a (VarNum, HeadRange)
goVarUpdate VarNum
newV
        Just Maybe HeadRange
Nothing ->
            forall start varDoc altDoc a r.
VarNum -> Pipeline start varDoc altDoc a r
throwV VarNum
v
        Just (Just HeadRange
hr) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarNum
newV, HeadRange
hr)
    where
        goVarUpdate :: VarNum -> Pipeline start varDoc altDoc a (VarNum, HeadRange)
goVarUpdate VarNum
newV = do
            T VarNum Rule
pegRules <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum Rule
ctxOriginalRules
            let rule :: Rule
rule = forall n a. T n => Array n a -> n -> a
AlignableArray.forceIndex T VarNum Rule
pegRules VarNum
v
            HeadRange
hr <- forall start varDoc altDoc a.
VarNum -> Rule -> Pipeline start varDoc altDoc a HeadRange
pegRuleHeadRangePipeline VarNum
newV Rule
rule
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarNum
newV, HeadRange
hr)

pegRuleHeadRangePipeline
    :: LAPEG.VarNum -> PEG.Rule
    -> Pipeline start varDoc altDoc a LAPEG.HeadRange
pegRuleHeadRangePipeline :: forall start varDoc altDoc a.
VarNum -> Rule -> Pipeline start varDoc altDoc a HeadRange
pegRuleHeadRangePipeline VarNum
newV (PEG.Rule [AltNum]
altns) = do
    T AltNum (Alt altDoc a)
originalAlts <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a -> T AltNum (Alt altDoc a)
ctxOriginalAlts
    let alts :: [Alt altDoc a]
alts = [ forall n a. T n => Array n a -> n -> a
AlignableArray.forceIndex T AltNum (Alt altDoc a)
originalAlts AltNum
altn | AltNum
altn <- [AltNum]
altns ]
    forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a ()
startUpdateAvailableRuleRange VarNum
newV
    HeadRange
newRange <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
        do \HeadRange
hr0 Alt altDoc a
alt -> do
            HeadRange
hr <- forall altDoc a start varDoc.
Alt altDoc a -> Pipeline start varDoc altDoc a HeadRange
pegAltHeadRangePipeline Alt altDoc a
alt
            forall (f :: * -> *) a. Applicative f => a -> f a
pure do HeadRange
hr0 forall a. Semigroup a => a -> a -> a
<> HeadRange
hr
        do forall a. Monoid a => a
mempty
        do [Alt altDoc a]
alts
    forall start varDoc altDoc a.
VarNum -> HeadRange -> Pipeline start varDoc altDoc a ()
saveNewRuleRange VarNum
newV HeadRange
newRange
    forall altDoc a start varDoc.
VarNum
-> HeadRange -> [Alt altDoc a] -> Pipeline start varDoc altDoc a ()
pushUpdateRuleItem VarNum
newV HeadRange
newRange [Alt altDoc a]
alts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadRange
newRange

pegAltHeadRangePipeline
    :: PEG.Alt altDoc a -> Pipeline start varDoc altDoc a LAPEG.HeadRange
pegAltHeadRangePipeline :: forall altDoc a start varDoc.
Alt altDoc a -> Pipeline start varDoc altDoc a HeadRange
pegAltHeadRangePipeline Alt altDoc a
alt =
    case forall altDoc a. Alt altDoc a -> AltKind
PEG.altKind Alt altDoc a
alt of
        AltKind
PEG.AltSeq -> Pipeline start varDoc altDoc a HeadRange
goStraight
        AltKind
PEG.AltNot -> Pipeline start varDoc altDoc a HeadRange
goNegative
        AltKind
PEG.AltAnd -> Pipeline start varDoc altDoc a HeadRange
goStraight
    where
        goStraight :: Pipeline start varDoc altDoc a HeadRange
goStraight = forall {start} {varDoc} {altDoc} {a}.
[Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits0 do forall altDoc a. Alt altDoc a -> [Unit]
PEG.altUnitSeq Alt altDoc a
alt

        goNegative :: Pipeline start varDoc altDoc a HeadRange
goNegative = do
            HeadRange
hr <- forall {start} {varDoc} {altDoc} {a}.
[Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits0 do forall altDoc a. Alt altDoc a -> [Unit]
PEG.altUnitSeq Alt altDoc a
alt
            let notHr :: HeadRange
notHr = if
                    | HeadRange -> Bool
LAPEG.headRangeEpsilon HeadRange
hr ->
                        forall a. Monoid a => a
mempty
                    | Bool
otherwise ->
                        LAPEG.HeadRange
                            { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
True
                            , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = T
SymbolicIntSet.full
                            }
            forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadRange
notHr

        goUnits0 :: [Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits0 [Unit]
us = forall {start} {varDoc} {altDoc} {a}.
T
-> [Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits forall a. Monoid a => a
mempty [Unit]
us

        goUnits :: T
-> [Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits T
consumeRange0 = \case
            [] -> do
                let hr :: HeadRange
hr = LAPEG.HeadRange
                        { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
True
                        , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = T
consumeRange0
                        }
                forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadRange
hr
            Unit
u:[Unit]
us -> do
                (Unit
_, HeadRange
hr) <- forall start varDoc altDoc a.
Unit -> Pipeline start varDoc altDoc a (Unit, HeadRange)
pegUnitPipeline Unit
u
                let consumeRange1 :: T
consumeRange1 = T
consumeRange0 forall a. Semigroup a => a -> a -> a
<> HeadRange -> T
LAPEG.headRangeConsume HeadRange
hr
                if HeadRange -> Bool
LAPEG.headRangeEpsilon HeadRange
hr
                    then
                        T
-> [Unit]
-> ExceptT
     (T VarNum) (State (Context start varDoc altDoc a)) HeadRange
goUnits T
consumeRange1 [Unit]
us
                    else do
                        let hr1 :: HeadRange
hr1 = LAPEG.HeadRange
                                { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
False
                                , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = T
consumeRange1
                                }
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadRange
hr1

pegRulePipeline
    :: LAPEG.VarNum -> LAPEG.HeadRange -> [PEG.Alt altDoc a]
    -> Pipeline start varDoc altDoc a ()
pegRulePipeline :: forall altDoc a start varDoc.
VarNum
-> HeadRange -> [Alt altDoc a] -> Pipeline start varDoc altDoc a ()
pegRulePipeline VarNum
newV HeadRange
newRange [Alt altDoc a]
alts = do
    [AltNum]
newAlts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Alt altDoc a]
alts \Alt altDoc a
alt -> forall altDoc a start varDoc.
VarNum -> Alt altDoc a -> Pipeline start varDoc altDoc a AltNum
pegAltPipeline VarNum
newV Alt altDoc a
alt
    let newRule :: Rule
newRule = LAPEG.Rule
            { $sel:ruleRange:Rule :: HeadRange
ruleRange = HeadRange
newRange
            , $sel:ruleAlts:Rule :: [AltNum]
ruleAlts = [AltNum]
newAlts
            }
    forall start varDoc altDoc a r.
T start varDoc altDoc a Identity r
-> Pipeline start varDoc altDoc a r
liftBuilder do forall (m :: * -> *) start varDoc altDoc a.
Monad m =>
VarNum -> Rule -> BuilderT start varDoc altDoc a m ()
LAPEGBuilder.addRule VarNum
newV Rule
newRule

pegAltPipeline
    :: LAPEG.VarNum -> PEG.Alt altDoc a
    -> Pipeline start varDoc altDoc a LAPEG.AltNum
pegAltPipeline :: forall altDoc a start varDoc.
VarNum -> Alt altDoc a -> Pipeline start varDoc altDoc a AltNum
pegAltPipeline VarNum
newV Alt altDoc a
alt =
    case forall altDoc a. Alt altDoc a -> AltKind
PEG.altKind Alt altDoc a
alt of
        AltKind
PEG.AltSeq -> Pipeline start varDoc altDoc a AltNum
goStraight
        AltKind
PEG.AltNot -> Pipeline start varDoc altDoc a AltNum
goNegative
        AltKind
PEG.AltAnd -> Pipeline start varDoc altDoc a AltNum
goStraight
    where
        goStraight :: Pipeline start varDoc altDoc a AltNum
goStraight = do
            (HeadRange
_, [(HeadRange, Unit)]
newUs) <- forall {start} {varDoc} {altDoc} {a}.
[Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goUnits do forall altDoc a. Alt altDoc a -> [Unit]
PEG.altUnitSeq Alt altDoc a
alt
            AltNum
newAlt <- [(HeadRange, Unit)] -> Pipeline start varDoc altDoc a AltNum
genNewAltNum [(HeadRange, Unit)]
newUs
            forall (f :: * -> *) a. Applicative f => a -> f a
pure AltNum
newAlt

        goNegative :: Pipeline start varDoc altDoc a AltNum
goNegative = do
            (HeadRange
hr, [(HeadRange, Unit)]
newUs) <- forall {start} {varDoc} {altDoc} {a}.
[Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goUnits do forall altDoc a. Alt altDoc a -> [Unit]
PEG.altUnitSeq Alt altDoc a
alt
            let notHr :: HeadRange
notHr = if
                    | HeadRange -> Bool
LAPEG.headRangeEpsilon HeadRange
hr ->
                        forall a. Monoid a => a
mempty
                    | Bool
otherwise ->
                        LAPEG.HeadRange
                            { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
True
                            , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = T
SymbolicIntSet.full
                            }
            AltNum
newAlt <- [(HeadRange, Unit)] -> Pipeline start varDoc altDoc a AltNum
genNewAltNum do (HeadRange
notHr, Unit
LAPEG.UnitNot)forall a. a -> [a] -> [a]
:[(HeadRange, Unit)]
newUs
            forall (f :: * -> *) a. Applicative f => a -> f a
pure AltNum
newAlt

        genNewAltNum :: [(HeadRange, Unit)] -> Pipeline start varDoc altDoc a AltNum
genNewAltNum [(HeadRange, Unit)]
newUs = do
            let newAlt :: Alt altDoc a
newAlt = LAPEG.Alt
                    { $sel:altVar:Alt :: VarNum
altVar = VarNum
newV
                    , $sel:altUnitSeqWithLookAHead:Alt :: T Position (HeadRange, Unit)
altUnitSeqWithLookAHead = forall n a. T n => [a] -> Array n a
AlignableArray.fromList [(HeadRange, Unit)]
newUs
                    , $sel:altKind:Alt :: AltKind
altKind = forall altDoc a. Alt altDoc a -> AltKind
PEG.altKind Alt altDoc a
alt
                    , $sel:altAction:Alt :: a
altAction = forall altDoc a. Alt altDoc a -> a
PEG.altAction Alt altDoc a
alt
                    , $sel:altHelp:Alt :: altDoc
altHelp = forall altDoc a. Alt altDoc a -> altDoc
PEG.altHelp Alt altDoc a
alt
                    }
            forall start varDoc altDoc a r.
T start varDoc altDoc a Identity r
-> Pipeline start varDoc altDoc a r
liftBuilder do forall (m :: * -> *) altDoc a start varDoc.
Monad m =>
Alt altDoc a -> BuilderT start varDoc altDoc a m AltNum
LAPEGBuilder.genNewAlt Alt altDoc a
newAlt

        goUnits :: [Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goUnits [Unit]
us = do
            let hr0 :: HeadRange
hr0 = LAPEG.HeadRange
                    { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
True
                    , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = forall a. Monoid a => a
mempty
                    }
            forall {start} {varDoc} {altDoc} {a}.
HeadRange
-> [(HeadRange, Unit)]
-> [Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goRevUnits HeadRange
hr0 [] do forall a. [a] -> [a]
reverse [Unit]
us

        goRevUnits :: HeadRange
-> [(HeadRange, Unit)]
-> [Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goRevUnits HeadRange
postRange [(HeadRange, Unit)]
newUs = \case
            [] ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (HeadRange
postRange, [(HeadRange, Unit)]
newUs)
            Unit
u:[Unit]
revUs -> do
                (Unit
newU, HeadRange
hrU) <- forall start varDoc altDoc a.
Unit -> Pipeline start varDoc altDoc a (Unit, HeadRange)
pegUnitPipeline Unit
u
                let hrUWithPost :: HeadRange
hrUWithPost = if HeadRange -> Bool
LAPEG.headRangeEpsilon HeadRange
hrU
                        then LAPEG.HeadRange
                            { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon =
                                HeadRange -> Bool
LAPEG.headRangeEpsilon HeadRange
postRange
                            , $sel:headRangeConsume:HeadRange :: T
headRangeConsume =
                                HeadRange -> T
LAPEG.headRangeConsume HeadRange
hrU forall a. Semigroup a => a -> a -> a
<> HeadRange -> T
LAPEG.headRangeConsume HeadRange
postRange
                            }
                        else HeadRange
hrU
                HeadRange
-> [(HeadRange, Unit)]
-> [Unit]
-> ExceptT
     (T VarNum)
     (State (Context start varDoc altDoc a))
     (HeadRange, [(HeadRange, Unit)])
goRevUnits HeadRange
hrUWithPost ((HeadRange
hrUWithPost, Unit
newU)forall a. a -> [a] -> [a]
:[(HeadRange, Unit)]
newUs) [Unit]
revUs

pegUnitPipeline
    :: PEG.Unit -> Pipeline start varDoc altDoc a (LAPEG.Unit, LAPEG.HeadRange)
pegUnitPipeline :: forall start varDoc altDoc a.
Unit -> Pipeline start varDoc altDoc a (Unit, HeadRange)
pegUnitPipeline = \case
    PEG.UnitTerminal Terminal
t -> do
        let hr :: HeadRange
hr = LAPEG.HeadRange
                { $sel:headRangeEpsilon:HeadRange :: Bool
headRangeEpsilon = Bool
False
                , $sel:headRangeConsume:HeadRange :: T
headRangeConsume = Terminal -> T
SymbolicIntSet.singleton Terminal
t
                }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Terminal -> Unit
LAPEG.UnitTerminal Terminal
t, HeadRange
hr)
    PEG.UnitNonTerminal VarNum
v -> do
        (VarNum
newV, HeadRange
hr) <- forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a (VarNum, HeadRange)
pegVarPipeline VarNum
v
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarNum -> Unit
LAPEG.UnitNonTerminal VarNum
newV, HeadRange
hr)

getNewVar :: PEG.VarNum -> Pipeline start varDoc altDoc a LAPEG.VarNum
getNewVar :: forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a VarNum
getNewVar VarNum
vn = do
    T VarNum VarNum
vm0 <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum VarNum
ctxVarMap
    case forall n a. T n => n -> Map n a -> Maybe a
AlignableMap.lookup VarNum
vn T VarNum VarNum
vm0 of
        Just VarNum
newV ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure VarNum
newV
        Maybe VarNum
Nothing -> do
            T VarNum (Var varDoc)
originalVars <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Var varDoc)
ctxOriginalVars
            let v :: Var varDoc
v = forall n a. T n => Array n a -> n -> a
AlignableArray.forceIndex T VarNum (Var varDoc)
originalVars VarNum
vn
            VarNum
newV <- forall start varDoc altDoc a r.
T start varDoc altDoc a Identity r
-> Pipeline start varDoc altDoc a r
liftBuilder do forall (m :: * -> *) varDoc start altDoc a.
Monad m =>
Var varDoc -> BuilderT start varDoc altDoc a m VarNum
LAPEGBuilder.genNewVar Var varDoc
v
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
                forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx
                    {
                        $sel:ctxVarMap:Context :: T VarNum VarNum
ctxVarMap = forall n a. T n => n -> a -> Map n a -> Map n a
AlignableMap.insert VarNum
vn VarNum
newV
                            do forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum VarNum
ctxVarMap Context start varDoc altDoc a
ctx
                    }
            forall (f :: * -> *) a. Applicative f => a -> f a
pure VarNum
newV

startUpdateAvailableRuleRange :: LAPEG.VarNum -> Pipeline start varDoc altDoc a ()
startUpdateAvailableRuleRange :: forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a ()
startUpdateAvailableRuleRange VarNum
newV = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx
        { $sel:ctxAvailableRuleRanges:Context :: T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges = forall n a. T n => n -> a -> Map n a -> Map n a
AlignableMap.insert VarNum
newV
            do forall a. Maybe a
Nothing
            do forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges Context start varDoc altDoc a
ctx
        }

saveNewRuleRange
    :: LAPEG.VarNum -> LAPEG.HeadRange
    -> Pipeline start varDoc altDoc a ()
saveNewRuleRange :: forall start varDoc altDoc a.
VarNum -> HeadRange -> Pipeline start varDoc altDoc a ()
saveNewRuleRange VarNum
newV HeadRange
hr = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx
        { $sel:ctxAvailableRuleRanges:Context :: T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges = forall n a. T n => n -> a -> Map n a -> Map n a
AlignableMap.insert VarNum
newV
            do forall a. a -> Maybe a
Just HeadRange
hr
            do forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges Context start varDoc altDoc a
ctx
        }

getAvailableVar
    :: PEG.VarNum -> Pipeline start varDoc altDoc a (Maybe LAPEG.VarNum)
getAvailableVar :: forall start varDoc altDoc a.
VarNum -> Pipeline start varDoc altDoc a (Maybe VarNum)
getAvailableVar VarNum
v = do
    Context start varDoc altDoc a
ctx <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
get
    case forall n a. T n => n -> Map n a -> Maybe a
AlignableMap.lookup VarNum
v do forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum VarNum
ctxVarMap Context start varDoc altDoc a
ctx of
        Maybe VarNum
Nothing ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just VarNum
newV -> case forall n a. T n => n -> Map n a -> Maybe a
AlignableMap.lookup VarNum
newV do forall start varDoc altDoc a.
Context start varDoc altDoc a -> T VarNum (Maybe HeadRange)
ctxAvailableRuleRanges Context start varDoc altDoc a
ctx of
            Maybe (Maybe HeadRange)
Nothing ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just Maybe HeadRange
Nothing ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Just Just{} ->
                forall (f :: * -> *) a. Applicative f => a -> f a
pure do forall a. a -> Maybe a
Just VarNum
newV

popUpdateRuleItem
    :: Pipeline start varDoc altDoc a (Maybe (LAPEG.VarNum, LAPEG.HeadRange, [PEG.Alt altDoc a]))
popUpdateRuleItem :: forall start varDoc altDoc a.
Pipeline
  start varDoc altDoc a (Maybe (VarNum, HeadRange, [Alt altDoc a]))
popUpdateRuleItem = do
    [(VarNum, HeadRange, [Alt altDoc a])]
updateRuleStack <- forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx forall start varDoc altDoc a.
Context start varDoc altDoc a
-> [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack
    case [(VarNum, HeadRange, [Alt altDoc a])]
updateRuleStack of
        [] ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        (VarNum, HeadRange, [Alt altDoc a])
item:[(VarNum, HeadRange, [Alt altDoc a])]
items -> do
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx { $sel:ctxUpdateRuleStack:Context :: [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack = [(VarNum, HeadRange, [Alt altDoc a])]
items }
            forall (f :: * -> *) a. Applicative f => a -> f a
pure do forall a. a -> Maybe a
Just (VarNum, HeadRange, [Alt altDoc a])
item

pushUpdateRuleItem
    :: LAPEG.VarNum -> LAPEG.HeadRange -> [PEG.Alt altDoc a]
    -> Pipeline start varDoc altDoc a ()
pushUpdateRuleItem :: forall altDoc a start varDoc.
VarNum
-> HeadRange -> [Alt altDoc a] -> Pipeline start varDoc altDoc a ()
pushUpdateRuleItem VarNum
newV HeadRange
newRange [Alt altDoc a]
alts = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' \Context start varDoc altDoc a
ctx -> Context start varDoc altDoc a
ctx
        { $sel:ctxUpdateRuleStack:Context :: [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack = (VarNum
newV, HeadRange
newRange, [Alt altDoc a]
alts)forall a. a -> [a] -> [a]
:forall start varDoc altDoc a.
Context start varDoc altDoc a
-> [(VarNum, HeadRange, [Alt altDoc a])]
ctxUpdateRuleStack Context start varDoc altDoc a
ctx
        }

getCtx
    :: (Context start varDoc altDoc a -> r)
    -> Pipeline start varDoc altDoc a r
getCtx :: forall start varDoc altDoc a r.
(Context start varDoc altDoc a -> r)
-> Pipeline start varDoc altDoc a r
getCtx Context start varDoc altDoc a -> r
f = Context start varDoc altDoc a -> r
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
get

throwV :: PEG.VarNum -> Pipeline start varDoc altDoc a r
throwV :: forall start varDoc altDoc a r.
VarNum -> Pipeline start varDoc altDoc a r
throwV VarNum
v = forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE do forall n. T n => n -> Set n
AlignableSet.singleton VarNum
v

liftBuilder
    :: LAPEGBuilder.T start varDoc altDoc a Identity r
    -> Pipeline start varDoc altDoc a r
liftBuilder :: forall start varDoc altDoc a r.
T start varDoc altDoc a Identity r
-> Pipeline start varDoc altDoc a r
liftBuilder T start varDoc altDoc a Identity r
builder = do
    Context start varDoc altDoc a
ctx <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) s. Monad m => StateT s m s
get
    let (r
x, Context start varDoc altDoc a
builderCtx) = forall s a. State s a -> s -> (a, s)
runState T start varDoc altDoc a Identity r
builder do forall start varDoc altDoc a.
Context start varDoc altDoc a -> Context start varDoc altDoc a
ctxBuilder Context start varDoc altDoc a
ctx
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift do forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put do Context start varDoc altDoc a
ctx { $sel:ctxBuilder:Context :: Context start varDoc altDoc a
ctxBuilder = Context start varDoc altDoc a
builderCtx }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure r
x