module Database.Algebra.Rewrite.Traversal
( preOrder
, postOrder
, applyToAll
, topologically
, iteratively
, sequenceRewrites
) where
import Control.Monad
import qualified Data.IntMap as M
import qualified Data.Set as S
import qualified Database.Algebra.Dag as Dag
import Database.Algebra.Dag.Common
import Database.Algebra.Rewrite.DagRewrite
import Database.Algebra.Rewrite.Rule
applyToAll :: Rewrite o e (NodeMap p) -> RuleSet o p e -> Rewrite o e Bool
applyToAll inferProps rules = iterateRewrites False 0
where iterateRewrites anyChanges offset = do
nodes <- drop offset <$> M.keys <$> Dag.nodeMap <$> exposeDag
props <- inferProps
extras <- getExtras
matchedOffset <- traverseNodes offset props extras rules nodes
case matchedOffset of
Just o -> iterateRewrites True o
Nothing -> return anyChanges
traverseNodes :: Int -> NodeMap p -> e -> RuleSet o p e -> [AlgNode] -> Rewrite o e (Maybe Int)
traverseNodes offset props extras rules nodes =
case nodes of
n : ns -> do
changed <- applyRuleSet extras props rules n
if changed
then return $ Just offset
else traverseNodes (offset + 1) props extras rules ns
[] -> return Nothing
preOrder :: Dag.Operator o
=> Rewrite o e (NodeMap p)
-> RuleSet o p e
-> Rewrite o e Bool
preOrder inferAction rules =
let traversePre (changedPrev, mProps, visited) q =
if q `S.member` visited
then return (changedPrev, mProps, visited)
else do
props <- case mProps of
Just ps -> return ps
Nothing -> inferAction
e <- getExtras
changedSelf <- applyRuleSet e props rules q
mop <- operatorSafe q
case mop of
Just op -> do
let mProps' = if changedSelf then Nothing else Just props
let cs = Dag.opChildren op
(changedChild, mProps'', visited') <- foldM descend (changedSelf, mProps', visited) cs
let visited'' = S.insert q visited'
if changedChild
then return (True, Nothing, visited'')
else return (changedPrev || (changedSelf || changedChild), mProps'', visited'')
Nothing -> return (True, Nothing, visited)
descend (changedPrev, mProps, visited) c = do
props <- case mProps of
Just ps -> return ps
Nothing -> inferAction
traversePre (changedPrev, Just props, visited) c
in do
pm <- inferAction
rs <- rootNodes
(changed, _, _) <- foldM traversePre (False, Just pm, S.empty) rs
return changed
topologically :: Dag.Operator o
=> Rewrite o e (NodeMap p)
-> RuleSet o p e
-> Rewrite o e Bool
topologically inferAction rules = do
topoOrdering <- topsort
props <- inferAction
let rewriteNode changedPrev q = do
e <- getExtras
changed <- applyRuleSet e props rules q
return $ changed || changedPrev
foldM rewriteNode False topoOrdering where
postOrder :: Dag.Operator o
=> Rewrite o e (NodeMap p)
-> RuleSet o p e
-> Rewrite o e Bool
postOrder inferAction rules =
let traversePost (changedPrev, props, visited) q =
if q `S.member` visited
then return (changedPrev, props, visited)
else do
op <- operator q
let cs = Dag.opChildren op
(changedChild, mProps, visited') <- foldM descend (False, props, visited) cs
props' <- case mProps of
Just ps -> return ps
Nothing -> inferAction
e <- getExtras
mop <- operatorSafe q
case mop of
Just _ -> do
changedSelf <- applyRuleSet e props' rules q
let visited'' = S.insert q visited'
if changedSelf
then return (True, Nothing, visited'')
else return (changedChild || changedPrev, Just props', visited'')
Nothing -> return (True, Nothing, visited)
descend (changedPrev, mProps, visited) c = do
props <- case mProps of
Just ps -> return ps
Nothing -> inferAction
traversePost (changedPrev, Just props, visited) c
in do
pm <- inferAction
rs <- rootNodes
(changed, _, _) <- foldM traversePost (False, Just pm, S.empty) rs
return changed
iteratively :: Rewrite o e Bool -> Rewrite o e Bool
iteratively rewrite = aux False
where aux b = do
changed <- rewrite
if changed
then logGeneral ">>> Iterate" >> aux True
else return b
sequenceRewrites :: [Rewrite o e Bool] -> Rewrite o e Bool
sequenceRewrites rewrites = or <$> sequence rewrites