module Text.GrammarCombinators.Utils.IsReachable (
foldReachable,
foldReachableProper,
isReachable,
isReachableProper
) where
import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.UnfoldDepthFirst
import Control.Monad.State
newtype SeenGram phi = MkSG { seenIdx :: forall ix. phi ix -> Bool }
setSeen :: (EqFam phi) => phi ix -> SeenGram phi -> SeenGram phi
setSeen idx s = MkSG $ overrideIdxK (seenIdx s) idx True
nothingSeen :: SeenGram phi
nothingSeen = MkSG $ \_ -> False
type Folder phi n = forall ix. phi ix -> n -> n
newtype FoldReachableIntRule phi (r :: * -> *) t (rr :: * -> *) n v = MkFRIR {
foldRule :: Folder phi n -> n -> State (SeenGram phi) n
}
putSeen :: (EqFam phi) => phi ix -> State (SeenGram phi) ()
putSeen idx = modify $ setSeen idx
foldDeadEnd :: FoldReachableIntRule phi r t rr n v
foldDeadEnd = MkFRIR $ \_ n -> return n
foldVia :: FoldReachableIntRule phi r t rr n v -> FoldReachableIntRule phi r t rr n v' -> FoldReachableIntRule phi r t rr n v''
foldVia ra rb = MkFRIR $ \f n -> do n' <- foldRule ra f n
foldRule rb f n'
foldRef :: (EqFam phi) =>
phi ix -> FoldReachableIntRule phi r t rr n (rr ix) ->
FoldReachableIntRule phi r t rr n v
foldRef idx r = MkFRIR $ \f n -> do sg <- get
if seenIdx sg idx
then return n
else do putSeen idx
let n' = f idx n
foldRule r f n'
instance ProductionRule (FoldReachableIntRule phi r t rr n) where
ra >>> rb = foldVia ra rb
ra ||| rb = foldVia ra rb
die = foldDeadEnd
endOfInput = foldDeadEnd
instance PenaltyProductionRule (FoldReachableIntRule phi r t rr n) where
penalty _ r = MkFRIR $ foldRule r
instance BiasedProductionRule (FoldReachableIntRule phi r t rr n) where
(>|||) = (|||)
(<|||) = (|||)
instance EpsProductionRule (FoldReachableIntRule phi r t rr n) where
epsilon _ = foldDeadEnd
instance LiftableProductionRule (FoldReachableIntRule phi r t rr n) where
epsilonL _ _ = foldDeadEnd
instance TokenProductionRule (FoldReachableIntRule phi r t rr n) t where
token _ = foldDeadEnd
anyToken = foldDeadEnd
instance (EqFam phi) =>
SimpleRecProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where
ref' = foldRef
instance (EqFam phi) =>
SimpleLoopProductionRule (FoldReachableIntRule phi r t rr n) phi r rr where
manyRef' = foldRef
many1Ref' = foldRef
foldReachableProper :: forall phi r t rr ix n. (Domain phi) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix ->
(forall ix'. phi ix' -> n -> n) -> n -> n
foldReachableProper grammar idx f n =
evalState (foldRule (unfoldDepthFirstProper grammar idx) f n) nothingSeen
foldReachable :: forall phi r rr t ix n. (Domain phi) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix ->
(forall ix'. phi ix' -> n -> n) -> n -> n
foldReachable grammar idx f n =
evalState (foldRule (unfoldDepthFirst grammar idx) f n) nothingSeen
isReachable' :: forall phi r t rr ix ix'. (Domain phi) =>
(forall n.
GAnyExtendedContextFreeGrammar phi t r rr -> phi ix ->
(forall ix''. phi ix'' -> n -> n) -> n -> n) ->
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> phi ix' -> Bool
isReachable' fold' g start end =
fold' g start ((||) . eqIdx end) False
isReachable :: forall phi r t rr ix ix'. (Domain phi) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> phi ix' -> Bool
isReachable = isReachable' foldReachable
isReachableProper :: forall phi r t rr ix ix'. (Domain phi) =>
GAnyExtendedContextFreeGrammar phi t r rr ->
phi ix -> phi ix' -> Bool
isReachableProper = isReachable' foldReachableProper