module Text.GrammarCombinators.Utils.IsDead (
isDead
) where
import Text.GrammarCombinators.Base
import Text.GrammarCombinators.Utils.UnfoldDepthFirst
import Data.Maybe
import Control.Monad.State
data KnownDead phi = MkKD { knownDead :: forall ix. phi ix -> Maybe Bool }
newtype IsDeadRule phi (r :: * -> *) t (rr :: * -> *) v = MkIDR {
ruleIsDead :: State (KnownDead phi) (Bool, Bool)
}
cast :: IsDeadRule phi r t rr v -> IsDeadRule phi r t rr v'
cast = MkIDR . ruleIsDead
seqDead :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool)
seqDead (False, True) _ = (False, True)
seqDead _ (False, True) = (False, True)
seqDead (ra, da) (rb, db) = (ra || rb, da || db)
altDead :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool)
altDead (False, False) _ = (False, False)
altDead _ (False, False) = (False, False)
altDead (ra, da) (rb, db) = (ra || rb, da && db)
instance ProductionRule (IsDeadRule phi r t rr) where
ra >>> rb = MkIDR $ liftM2 seqDead (ruleIsDead ra) (ruleIsDead rb)
ra ||| rb = MkIDR $ liftM2 altDead (ruleIsDead ra) (ruleIsDead rb)
die = MkIDR $ return (False, True)
endOfInput = MkIDR $ return (False, False)
instance EpsProductionRule (IsDeadRule phi r t rr) where
epsilon _ = MkIDR $ return (False, False)
instance LiftableProductionRule (IsDeadRule phi r t rr) where
epsilonL _ _ = MkIDR $ return (False, False)
instance TokenProductionRule (IsDeadRule phi r t rr) t where
token _ = anyToken
anyToken = MkIDR $ return (False, False)
instance PenaltyProductionRule (IsDeadRule phi r t rr) where
penalty _ r = r
instance BiasedProductionRule (IsDeadRule phi r t rr) where
(>|||) = (|||)
(<|||) = (|||)
instance (EqFam phi, MemoFam phi) =>
SimpleRecProductionRule (IsDeadRule phi r t rr) phi r rr where
ref' idx r = MkIDR $ do kds <- get
case knownDead kds idx of
(Just kd) -> return (False, kd)
_ -> do (rl,d) <- ruleIsDead r
unless rl $ putDeath idx d
return (rl, d)
cutRecursion _ = MkIDR $ return (True, True)
instance (EqFam phi, MemoFam phi) =>
SimpleLoopProductionRule (IsDeadRule phi r t rr) phi r rr where
manyRef' _ _ = MkIDR $ return (False, False)
many1Ref' idx r = cast (ref' idx r)
putDeath :: (EqFam phi, MemoFam phi) => phi ix -> Bool ->
State (KnownDead phi) ()
putDeath idx d =
do let setDead kd = MkKD $ memoFamilyK $ overrideIdxK (knownDead kd) idx $ Just d
modify setDead
isDead :: forall phi t r rr ix. (EqFam phi, FoldFam phi, MemoFam phi) =>
GExtendedContextFreeGrammar phi t r rr ->
phi ix -> Bool
isDead gram =
let
ikd :: KnownDead phi
ikd = MkKD $ \_ -> Nothing
checkDead idx =
do (_,d) <- ruleIsDead (unfoldDepthFirst gram idx)
putDeath idx d
checkAll = foldFam ((>>) . checkDead) (return ())
in fromJust . knownDead (execState checkAll ikd)