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 }
newtype Folder phi n = MkFF { foldIdxs :: (forall ix. phi ix -> n -> n) -> n -> n }
newtype FoldReachableIntRule phi (r :: * -> *) t (rr :: * -> *) n v = MkFRIR {
foldRule :: State (SeenGram phi) (Folder phi n)
}
combineFolders :: Folder phi n -> Folder phi n -> Folder phi n
combineFolders a b = MkFF $ \f n -> foldIdxs a f $ foldIdxs b f n
foldDeadEnd :: FoldReachableIntRule phi r t rr n v
foldDeadEnd = MkFRIR $ return $ MkFF $ \_ n -> 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 $ do fa <- foldRule ra
fb <- foldRule rb
return $ combineFolders fa fb
setSeen :: (EqFam phi) => phi ix -> SeenGram phi -> SeenGram phi
setSeen idx s = MkSG $ overrideIdxK (seenIdx s) idx True
putSeen :: (EqFam phi) => phi ix -> State (SeenGram phi) ()
putSeen idx = modify $ setSeen idx
noFold :: Folder phi n
noFold = MkFF $ const id
foldIdx :: phi ix -> Folder phi n
foldIdx idx = MkFF $ \f n -> f idx 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 $ do s <- get
if seenIdx s idx
then return noFold
else do putSeen idx
frec <- foldRule r
return $ combineFolders frec $ foldIdx idx
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
nothingSeen :: SeenGram phi
nothingSeen = MkSG $ \_ -> False
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 =
foldIdxs $ evalState (foldRule (unfoldDepthFirstProper grammar idx)) 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 =
foldIdxs $ evalState (foldRule (unfoldDepthFirst grammar idx)) 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