module Text.GrammarCombinators.Utils.UnfoldDepthFirst where
import Text.GrammarCombinators.Base
class (ProductionRule p) =>
SimpleRecProductionRule p phi r rr | p -> phi, p -> r, p -> rr where
ref' :: phi ix -> p (rr ix) -> p (r ix)
cutRecursion :: phi ix -> p (rr ix)
cutRecursion _ = die
class SimpleLoopProductionRule p phi r rr | p -> phi, p -> r, p -> rr where
manyRef' :: phi ix -> p (rr ix) -> p [r ix]
many1Ref' :: phi ix -> p (rr ix) -> p [r ix]
newtype UnfoldDepthFirstRule p (phi :: * -> *) (r :: * -> *) t (rr :: * -> *) v = MkFRR {
foldReachableFromRule :: UDFGrammar p phi r t rr -> p v
}
type UDFGrammar p phi r t rr =
forall ix. phi ix -> p (rr ix)
instance (ProductionRule p) => ProductionRule (UnfoldDepthFirstRule p phi r t rr) where
ra >>> rb = MkFRR $ \g -> foldReachableFromRule ra g >>> foldReachableFromRule rb g
ra ||| rb = MkFRR $ \g -> foldReachableFromRule ra g ||| foldReachableFromRule rb g
die = MkFRR $ \_ -> die
endOfInput = MkFRR $ \_ -> endOfInput
instance (BiasedProductionRule p) => BiasedProductionRule (UnfoldDepthFirstRule p phi r t rr) where
ra >||| rb = MkFRR $ \g -> foldReachableFromRule ra g >||| foldReachableFromRule rb g
ra <||| rb = MkFRR $ \g -> foldReachableFromRule ra g <||| foldReachableFromRule rb g
instance (EpsProductionRule p) => EpsProductionRule (UnfoldDepthFirstRule p phi r t rr) where
epsilon v = MkFRR $ \_ -> epsilon v
instance (LiftableProductionRule p) => LiftableProductionRule (UnfoldDepthFirstRule p phi r t rr) where
epsilonL v q = MkFRR $ \_ -> epsilonL v q
instance (TokenProductionRule p t) =>
TokenProductionRule (UnfoldDepthFirstRule p phi r t rr) t where
token tt = MkFRR $ \_ -> token tt
anyToken = MkFRR $ \_ -> anyToken
instance (SimpleRecProductionRule p phi r rr) =>
RecProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where
ref idx = MkFRR $ \g -> ref' idx (g idx)
instance (PenaltyProductionRule p) =>
PenaltyProductionRule (UnfoldDepthFirstRule p phi r t rr) where
penalty _ r = r
instance (ProductionRule p,
LiftableProductionRule p,
SimpleRecProductionRule p phi r rr,
SimpleLoopProductionRule p phi r rr) =>
LoopProductionRule (UnfoldDepthFirstRule p phi r t rr) phi r where
manyRef idx = MkFRR $ \g -> manyRef' idx (g idx)
many1Ref idx = MkFRR $ \g -> many1Ref' idx (g idx)
newtype WrapUR p r ix = WUR { unWUR :: p (r ix) }
declareDead :: (EqFam phi, ProductionRule p,
SimpleRecProductionRule p phi r rr) =>
phi ix ->
UDFGrammar p phi r t rr ->
UDFGrammar p phi r t rr
declareDead idx g = unWUR . overrideIdx (WUR . g) idx (WUR $ cutRecursion idx)
unfoldDepthFirst'' :: forall p phi r rr t v.
(ProductionRule p, EqFam phi,
TokenProductionRule p t,
EpsProductionRule p,
BiasedProductionRule p,
PenaltyProductionRule p,
SimpleRecProductionRule p phi r rr,
SimpleLoopProductionRule p phi r rr) =>
UnfoldDepthFirstRule p phi r t rr v ->
GAnyExtendedContextFreeGrammar phi t r rr ->
(UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->
p v
unfoldDepthFirst'' r grammar rg =
foldReachableFromRule r (rg (unfoldDepthFirst' grammar rg))
unfoldDepthFirst' :: forall p phi r rr t ix.
(ProductionRule p, EqFam phi,
EpsProductionRule p,
PenaltyProductionRule p,
BiasedProductionRule p,
TokenProductionRule p t,
SimpleRecProductionRule p phi r rr,
SimpleLoopProductionRule p phi r rr) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
(UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr) ->
phi ix -> p (rr ix)
unfoldDepthFirst' grammar rg idx =
let
nrg :: UDFGrammar p phi r t rr -> UDFGrammar p phi r t rr
nrg g = declareDead idx (rg g)
in unfoldDepthFirst'' (grammar idx) grammar nrg
unfoldDepthFirstProper :: forall p phi r rr t ix.
(ProductionRule p, EqFam phi,
EpsProductionRule p,
PenaltyProductionRule p,
BiasedProductionRule p,
TokenProductionRule p t,
SimpleRecProductionRule p phi r rr,
SimpleLoopProductionRule p phi r rr) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> p (rr ix)
unfoldDepthFirstProper grammar = unfoldDepthFirst' grammar (\g -> g)
unfoldDepthFirst :: forall p phi r rr t ix.
(ProductionRule p, EqFam phi,
EpsProductionRule p,
PenaltyProductionRule p,
BiasedProductionRule p,
TokenProductionRule p t,
SimpleRecProductionRule p phi r rr,
SimpleLoopProductionRule p phi r rr) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> p (r ix)
unfoldDepthFirst grammar idx = unfoldDepthFirst'' (ref idx) grammar (\g -> g)