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]))
= 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