packages feed

algebra-dag (empty) → 0.1.0.0

raw patch · 14 files changed

+1605/−0 lines, 14 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, fgl, mtl, parsec, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Eberhard Karls Universität Tübingen 2010++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ algebra-dag.cabal view
@@ -0,0 +1,43 @@+cabal-version: >=1.8+Name:           algebra-dag+synopsis:       Infrastructure for DAG-shaped relational algebra plans+Category:       Database+Version:        0.1.0.0+Description:    This library contains infrastructure for DAG-shaped plans of relational operators.+                It offers an API for construction and modification of algebra plans and a DSL+                for specifying rewrites on plans. Examples of usage can be found in the packages+                <http://hackage.haskell.org/package/DSH DSH> and +                <http://hackage.haskell.org/package/algebra-sql algebra-sql>+License:        BSD3+License-file:   LICENSE+Author:		Alexander Ulrich+Maintainer:	alex@etc-network.de+Build-Type:     Simple++library+    buildable:        True+    build-depends:    base               >= 4.7 && < 5,  +                      mtl                >= 2.1, +                      containers         >= 0.5, +                      template-haskell   >= 2.9, +                      fgl                >= 5.5, +                      transformers       >= 0.3, +                      parsec             >= 3.1,+                      aeson              >= 0.8++    exposed-modules:  Database.Algebra.Dag+                      Database.Algebra.Dag.Build+                      Database.Algebra.Dag.Common++                      Database.Algebra.Rewrite+                      Database.Algebra.Rewrite.Match+                      Database.Algebra.Rewrite.Traversal+                      Database.Algebra.Rewrite.Rule+                      Database.Algebra.Rewrite.Properties+                      Database.Algebra.Rewrite.PatternConstruction+                      Database.Algebra.Rewrite.DagRewrite++    hs-source-dirs:   src+    GHC-Options:       -Wall -fno-warn-orphans+    other-modules:    Database.Algebra.Rewrite.PatternSyntax		      +
+ src/Database/Algebra/Dag.hs view
@@ -0,0 +1,285 @@+module Database.Algebra.Dag+       (+         -- * The DAG data structure+         AlgebraDag+       , Operator(..)+       , nodeMap+       , rootNodes+       , refCountMap+       , mkDag+       , emptyDag+       , addRootNodes+         -- * Query functions for topological and operator information+       , parents+         -- FIXME is topological sorting still necessary?+       , topsort+       , hasPath+       , reachableNodesFrom+       , operator+         -- * DAG modification functions+       , insert+       , insertNoShare+       , replaceChild+       , replaceRoot+       , collect+       ) where+       +import           Control.Exception.Base+import qualified Data.Graph.Inductive.Graph        as G+import           Data.Graph.Inductive.PatriciaTree+import qualified Data.Graph.Inductive.Query.DFS    as DFS+import qualified Data.IntMap                       as IM+import qualified Data.List                         as L+import qualified Data.Map                          as M+import qualified Data.Set                          as S++import           Database.Algebra.Dag.Common++data AlgebraDag a = AlgebraDag+  { nodeMap     :: NodeMap a       -- ^ Return the nodemap of a DAG+  , opMap       :: M.Map a AlgNode -- ^ reverse index from operators to nodeids+  , nextNodeID  :: AlgNode         -- ^ the next node id to be used when inserting a node+  , graph       :: UGr             -- ^ Auxilliary representation for topological information+  , rootNodes   :: [AlgNode]       -- ^ Return the (possibly modified) list of root nodes from a DAG+  , refCountMap :: NodeMap Int     -- ^ A map storing the number of parents for each node.+  }++class (Ord a, Show a) => Operator a where+    opChildren     :: a -> [AlgNode]+    replaceOpChild :: a -> AlgNode -> AlgNode -> a++-- For every node, count the number of parents (or list of edges to the node).+-- We don't consider the graph a multi-graph, so an edge (u, v) is only counted+-- once.  We insert one virtual edge for every root node, to make sure that root+-- nodes are not pruned if they don't have any incoming edges.+initRefCount :: Operator o => [AlgNode] -> NodeMap o -> NodeMap Int+initRefCount rs nm = L.foldl' incParents (IM.foldr' insertEdge IM.empty nm) (L.nub rs)+  where +    insertEdge op rm = L.foldl' incParents rm (L.nub $ opChildren op)+    incParents rm n  = IM.insert n ((IM.findWithDefault 0 n rm) + 1) rm++initOpMap :: Ord o => NodeMap o -> M.Map o AlgNode+initOpMap nm = IM.foldrWithKey (\n o om -> M.insert o n om) M.empty nm++-- | Create a DAG from a node map of algebra operators and a list of+-- root nodes. Nodes which are not reachable from the root nodes+-- provided will be pruned!+mkDag :: Operator a => NodeMap a -> [AlgNode] -> AlgebraDag a+mkDag m rs = AlgebraDag { nodeMap = mNormalized+                        , graph = g+                        , rootNodes = rs+                        , refCountMap = initRefCount rs mNormalized+                        , opMap = initOpMap mNormalized+                        , nextNodeID = 1 + (fst $ IM.findMax mNormalized)+                        }+  where +    mNormalized = normalizeMap rs m+    g =  uncurry G.mkUGraph $ IM.foldrWithKey aux ([], []) mNormalized+    aux n op (allNodes, allEdges) = (n : allNodes, es ++ allEdges)+      where +        es = map (\v -> (n, v)) $ opChildren op++-- | Construct an empty DAG with no root nodes. Beware: before any+-- collections are performed, root nodes must be added. Otherwise, all+-- nodes will be considered unreachable.+emptyDag :: AlgebraDag a+emptyDag = +    AlgebraDag { nodeMap     = IM.empty+               , opMap       = M.empty+               , nextNodeID  = 1+               , graph       = G.mkUGraph [] []+               , rootNodes   = []+               , refCountMap = IM.empty+               }++-- | Add a list of root nodes to a DAG, all of which must be present+-- in the DAG. The node map is normalized by removing all nodes which+-- are not reachable from the root nodes.+-- FIXME re-use graph, opmap etc, only remove pruned nodes.+addRootNodes :: Operator a => AlgebraDag a -> [AlgNode] -> AlgebraDag a+addRootNodes d rs = assert (all (\n -> IM.member n $ nodeMap d) rs) $+    d { rootNodes = rs+      , nodeMap     = mNormalized+      , refCountMap = initRefCount rs mNormalized+      , opMap       = initOpMap mNormalized+      , graph       =  uncurry G.mkUGraph $ IM.foldrWithKey aux ([], []) mNormalized+      }++  where+    mNormalized     = normalizeMap rs (nodeMap d)++    aux n op (allNodes, allEdges) = (n : allNodes, es ++ allEdges)+      where +        es = map (\v -> (n, v)) $ opChildren op++reachable :: Operator a => NodeMap a -> [AlgNode] -> S.Set AlgNode+reachable m rs = L.foldl' traverse S.empty rs+  where traverse :: S.Set AlgNode -> AlgNode -> S.Set AlgNode+        traverse s n = if S.member n s+                       then s+                       else L.foldl' traverse (S.insert n s) (opChildren $ lookupOp n)++        lookupOp n = case IM.lookup n m of+                       Just op -> op+                       Nothing -> error $ "node not present in map: " ++ (show n)++normalizeMap :: Operator a => [AlgNode] -> NodeMap a -> NodeMap a+normalizeMap rs m =+  let reachableNodes = reachable m rs+  in IM.filterWithKey (\n _ -> S.member n reachableNodes) m++-- Utility functions to maintain the reference counter map and eliminate no+-- longer referenced nodes.++lookupRefCount :: AlgNode -> AlgebraDag a -> Int+lookupRefCount n d =+  case IM.lookup n (refCountMap d) of+    Just c  -> c+    Nothing -> error $ "no refcount value for node " ++ (show n)++decrRefCount :: AlgebraDag a -> AlgNode -> AlgebraDag a+decrRefCount d n =+  let refCount = lookupRefCount n d+      refCount' = assert (refCount /= 0) $ refCount - 1+  in d { refCountMap = IM.insert n refCount' (refCountMap d) }++-- | Delete a node from the node map and the aux graph+-- Beware: this leaves the DAG in an inconsistent state, because+-- reference counters have to be updated.+delete' :: Operator a => AlgNode -> AlgebraDag a -> AlgebraDag a+delete' n d =+  let op     = operator n d+      g'     = G.delNode n $ graph d+      m'     = IM.delete n $ nodeMap d+      rc'    = IM.delete n $ refCountMap d+      opMap' = case M.lookup op $ opMap d of+                 Just n' | n == n' -> M.delete op $ opMap d+                 _                 -> opMap d+  in d { nodeMap = m', graph = g', refCountMap = rc', opMap = opMap' }++refCountSafe :: AlgNode -> AlgebraDag o -> Maybe Int+refCountSafe n d = IM.lookup n $ refCountMap d++collect :: Operator o => S.Set AlgNode -> AlgebraDag o -> AlgebraDag o+collect collectNodes d = S.foldl' tryCollectNode d collectNodes+  where tryCollectNode :: (Show o, Operator o) => AlgebraDag o -> AlgNode -> AlgebraDag o+        tryCollectNode di n =+          case refCountSafe n di of+            Just rc -> if rc == 0+                       then -- node is unreferenced -> collect it+                            let cs = L.nub $ opChildren $ operator n di+                                d' = delete' n di+                            in L.foldl' cutEdge d' cs++                       else di -- node is still referenced+            Nothing -> di++-- Cut an edge to a node reference counting wise.+-- If the ref count becomes zero, the node is deleted and the children are+-- traversed.++cutEdge :: Operator a => AlgebraDag a -> AlgNode -> AlgebraDag a+cutEdge d edgeTarget =+  let d'          = decrRefCount d edgeTarget+      newRefCount = lookupRefCount edgeTarget d'+  in if newRefCount == 0+     then let cs  = L.nub $ opChildren $ operator edgeTarget d'+              d'' = delete' edgeTarget d'+          in L.foldl' cutEdge d'' cs+     else d'++addRefTo :: AlgebraDag a -> AlgNode -> AlgebraDag a+addRefTo d n =+  let refCount = lookupRefCount n d+  in d { refCountMap = IM.insert n (refCount + 1) (refCountMap d) }++-- | Replace an entry in the list of root nodes with a new node. The root node must be+-- present in the DAG.+replaceRoot :: Operator a => AlgebraDag a -> AlgNode -> AlgNode -> AlgebraDag a+replaceRoot d old new =+  if old `elem` (rootNodes d)+  then let rs'         = map doReplace $ rootNodes d+           doReplace r = if r == old then new else r+           d'          = d { rootNodes = rs' }+       in -- cut the virtual edge to the old root+          -- and insert a virtual edge to the new root+          assert (old /= new) $ addRefTo (decrRefCount d' old) new+  else d++-- | Insert a new node into the DAG.+insert :: Operator a => a -> AlgebraDag a -> (AlgNode, AlgebraDag a)+insert op d =+  -- check if an equivalent operator is already present+  case M.lookup op $ opMap d of+    Just n  -> (n, d)+    -- no operator can be reused, insert a new one+    Nothing -> insertNoShare op d++-- | Insert an operator without checking if an equivalent operator is+-- already present.+insertNoShare :: Operator a => a -> AlgebraDag a -> (AlgNode, AlgebraDag a)+insertNoShare op d =+  let cs     = L.nub $ opChildren op+      n      = nextNodeID d+      g'     = G.insEdges (map (\c -> (n, c, ())) cs) $ G.insNode (n, ()) $ graph d+      m'     = IM.insert n op $ nodeMap d+      rc'    = IM.insert n 0 $ refCountMap d+      opMap' = M.insert op n $ opMap d+      d'     = d { nodeMap = m'+                 , graph = g'+                 , refCountMap = rc'+                 , opMap = opMap'+                 , nextNodeID = n + 1+                 }+  in (n, L.foldl' addRefTo d' cs)++-- | Return the list of parents of a node.+parents :: AlgNode -> AlgebraDag a -> [AlgNode]+parents n d = G.pre (graph d) n++-- | 'replaceChild n old new' replaces all links from node n to node old with links to node new.+replaceChild :: Operator a => AlgNode -> AlgNode -> AlgNode -> AlgebraDag a -> AlgebraDag a+replaceChild parent old new d =+  let op = operator parent d+  in if old `elem` opChildren op && old /= new+     then let op' = replaceOpChild op old new+              m'  = IM.insert parent op' $ nodeMap d+              om' = M.insert op' parent $ M.delete op $ opMap d+              g'  = G.insEdge (parent, new, ()) $ G.delEdge (parent, old) $ graph d+              d'  = d { nodeMap = m', graph = g', opMap = om' }++              -- Update reference counters if nodes are not simply+              -- inserted or deleted but edges are replaced by other+              -- edges.  We must not delete nodes before the new edges+              -- have been taken into account. Only after that can we+              -- certainly say that a node is no longer referenced+              -- (edges might be replaced by themselves).++              -- First, decrement refcounters for the old child+              d'' = decrRefCount d' old+          in -- Then, increment refcounters for the new child if the link was+             -- not already present (we do not count multi-edges separately)+             if new `elem` G.suc (graph d) parent+             then d''+             else addRefTo d'' new+          +     else d++-- | Returns the operator for a node.+operator :: Operator a => AlgNode -> AlgebraDag a -> a+operator n d =+    case IM.lookup n $ nodeMap d of+        Just op -> op+        Nothing -> error $ "AlgebraDag.operator: lookup failed for " ++ (show n) ++ "\n" ++ (show $ map fst $ IM.toList $ nodeMap d)++-- | Return a topological ordering of all nodes which are reachable from the root nodes.+topsort :: Operator a => AlgebraDag a -> [AlgNode]+topsort d = DFS.topsort $ graph d++-- | Return all nodes that are reachable from one node.+reachableNodesFrom :: AlgNode -> AlgebraDag a -> S.Set AlgNode+reachableNodesFrom n d = S.fromList $ DFS.reachable n $ graph d++-- | Tests wether there is a path from the first to the second node.+hasPath :: AlgNode -> AlgNode -> AlgebraDag a -> Bool+hasPath a b d = b `S.member` (reachableNodesFrom a d)
+ src/Database/Algebra/Dag/Build.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE GADTs #-}++module Database.Algebra.Dag.Build+    ( Build+    , runBuild+    , tagM+    , insert+    , insertNoShare+    ) where++import           Control.Monad.State+import qualified Data.IntMap                 as IM++import qualified Database.Algebra.Dag        as Dag+import           Database.Algebra.Dag.Common+++data BuildState alg = BuildState+    { dag  :: Dag.AlgebraDag alg  -- ^ The operator DAG that is built+    , tags :: NodeMap [Tag]       -- ^ Tags for nodes+    }++-- | The DAG builder monad, abstracted over the algebra stored in the+-- DAG. Internally, the monad detects sharing of subgraphs via hash+-- consing.+type Build alg = State (BuildState alg)++-- | Evaluate the monadic graph into an algebraic plan, given a loop+-- relation.+runBuild :: Build alg r -> (Dag.AlgebraDag alg, r, NodeMap [Tag])+runBuild m = (dag s, r, tags s)+  where +    initialBuildState = BuildState { dag = Dag.emptyDag, tags = IM.empty }+    (r, s)            = runState m initialBuildState++-- | Tag a subtree with a comment+tag :: String -> AlgNode -> Build alg AlgNode+tag msg c = do+    modify $ \s -> s { tags = IM.insertWith (++) c [msg] $ tags s }+    return c++-- | Tag a subtree with a comment (monadic version)+tagM :: String -> Build alg AlgNode -> Build alg AlgNode+tagM s = (=<<) (tag s)++-- | Insert a node into the graph construction environment, first check if the node already exists+-- | if so return its id, otherwise insert it and return its id.+insert :: Dag.Operator alg => alg -> Build alg AlgNode+insert op = do+    d <- gets dag+    let (n, d') = Dag.insert op d+    modify $ \s -> s { dag = d' }+    return n++insertNoShare :: Dag.Operator alg => alg -> Build alg AlgNode+insertNoShare op = do+    d <- gets dag+    let (n, d') = Dag.insertNoShare op d+    modify $ \s -> s { dag = d' }+    return n
+ src/Database/Algebra/Dag/Common.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveGeneric #-}+module Database.Algebra.Dag.Common where++import qualified Data.IntMap  as IM+import qualified Data.Map     as M+import           GHC.Generics (Generic)++import           Data.Aeson   (FromJSON, ToJSON)++-- | Identifiers for DAG nodes.+type AlgNode = Int++type AlgMap alg = M.Map alg AlgNode+type NodeMap a = IM.IntMap a++type Tag = String++-- | Tertiary, Binary, unary and leaf nodes of a relational algebra DAG.+data Algebra t b u n c = TerOp t c c c+                       | BinOp b c c+                       | UnOp u c+                       | NullaryOp n+                         deriving (Ord, Eq, Show, Read, Generic)++instance (ToJSON t, ToJSON b, ToJSON u, ToJSON n, ToJSON c) => ToJSON (Algebra t b u n c) where+instance (FromJSON t, FromJSON b, FromJSON u, FromJSON n, FromJSON c) => FromJSON (Algebra t b u n c) where
+ src/Database/Algebra/Rewrite.hs view
@@ -0,0 +1,21 @@+module Database.Algebra.Rewrite+       ( -- * DAG rewriting+         module Database.Algebra.Rewrite.DagRewrite+         -- * Rewrite rules+       , module Database.Algebra.Rewrite.Rule+         -- * DAG matching+       , module Database.Algebra.Rewrite.Match+         -- * DAG traversal+       , module Database.Algebra.Rewrite.Traversal+         -- * Property inference+       , module Database.Algebra.Rewrite.Properties+         -- * Pattern syntax+       , module Database.Algebra.Rewrite.PatternConstruction+       ) where++import           Database.Algebra.Rewrite.DagRewrite+import           Database.Algebra.Rewrite.Match+import           Database.Algebra.Rewrite.PatternConstruction (dagPatMatch, v)+import           Database.Algebra.Rewrite.Properties+import           Database.Algebra.Rewrite.Rule+import           Database.Algebra.Rewrite.Traversal
+ src/Database/Algebra/Rewrite/DagRewrite.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | This module provides a monadic interface to rewrites on algebra DAGs.+module Database.Algebra.Rewrite.DagRewrite+       (+         -- ** The Rewrite monad+         Rewrite+       , runRewrite+       , initRewriteState+       , Log+       , logGeneral+       , logRewrite+       , reachableNodesFrom+       , parents+       , topsort+       , operator+       , operatorSafe+       , rootNodes+       , exposeDag+       , getExtras+       , updateExtras+       , condRewrite+       , insert+       , insertNoShare+       , replaceChild+       , replace+       , replaceWithNew+       , replaceRoot+       , infer+       , collect+       ) where++import           Control.Applicative+import           Control.Monad.State+import           Control.Monad.Writer+import qualified Data.IntMap                 as IM+import qualified Data.Sequence               as Seq+import qualified Data.Set                    as S+import           Debug.Trace++import qualified Database.Algebra.Dag        as Dag+import           Database.Algebra.Dag.Common++-- | Cache some topological information about the DAG.+data Cache = Cache { cachedTopOrdering :: Maybe [AlgNode] }++emptyCache :: Cache+emptyCache = Cache Nothing++data RewriteState o e = RewriteState+  { dag            :: Dag.AlgebraDag o -- ^ The DAG itself+  , cache          :: Cache            -- ^ Cache of some topological information+  , extras         :: e                -- ^ Polymorphic container for whatever needs to be provided additionally.+  , debugFlag      :: Bool             -- ^ Wether to output log messages via Debug.Trace.trace+  , collectNodes   :: S.Set AlgNode    -- ^ List of nodes which must be checked during garbage collection+  }++-- | A Monad for DAG rewrites, parameterized over the type of algebra operators.+newtype Rewrite o e a = R (WriterT Log (State (RewriteState o e)) a) deriving (Monad, Functor, Applicative)++-- FIXME Map.findMax might call error+initRewriteState :: (Ord o, Dag.Operator o) => Dag.AlgebraDag o -> e -> Bool -> RewriteState o e+initRewriteState d e debug =+    RewriteState { dag = d+                 , cache = emptyCache+                 , extras = e+                 , debugFlag = debug+                 , collectNodes = S.empty+                 }++-- | Run a rewrite action on the supplied graph. Returns the rewritten node map, the potentially+-- modified list of root nodes, the result of the rewrite and the rewrite log.+runRewrite :: Dag.Operator o => Rewrite o e r -> Dag.AlgebraDag o -> e -> Bool -> (Dag.AlgebraDag o, e, r, Log)+runRewrite (R m) d e debug = (dag s, extras s, res, rewriteLog)+  where ((res, rewriteLog), s) = runState (runWriterT m) (initRewriteState d e debug)++-- | The log from a sequence of rewrite actions.+type Log = Seq.Seq String++-- FIXME unwrapR should not be necessary: just provide a type alias for the monad stack+unwrapR :: Rewrite o e a -> WriterT Log (State (RewriteState o e)) a+unwrapR (R m) = m++invalidateCacheM :: Rewrite o e ()+invalidateCacheM =+  R $ do+    s <- get+    put $ s { cache = emptyCache }++-- internal helper function+putDag :: Dag.AlgebraDag o -> Rewrite o e ()+putDag d =+  R $ do+    s <- get+    put $ s { dag = d }++putCache :: Cache -> Rewrite o e ()+putCache c =+  R $ do+    s <- get+    put $ s { cache = c }++-- | Log a general message+logGeneral :: String -> Rewrite o e ()+logGeneral msg =  do+  d <- R $ gets debugFlag+  if d+    then trace msg $ R $ tell $ Seq.singleton msg+    else R $ tell $ Seq.singleton msg++-- | Log a rewrite+logRewrite :: String -> AlgNode -> Rewrite o e ()+logRewrite rewrite node =+  logGeneral $ "Triggering rewrite " ++ rewrite ++ " at node " ++ (show node)++-- | Return the set of nodes that are reachable from the specified node.+reachableNodesFrom :: AlgNode -> Rewrite o e (S.Set AlgNode)+reachableNodesFrom n =+  R $ do+    d <- gets dag+    return $ Dag.reachableNodesFrom n d++-- | Return the parents of a node+parents :: AlgNode -> Rewrite o e [AlgNode]+parents n = R $ gets ((Dag.parents n) . dag)++-- | Return a topological ordering of all reachable nodes in the DAG.+topsort :: Dag.Operator o => Rewrite o e [AlgNode]+topsort =+  R $ do+    s <- get+    let c = cache s+    case cachedTopOrdering c of+      Just o -> return o+      Nothing -> do+        let d = dag s+            ordering = Dag.topsort d+        unwrapR $ putCache $ c { cachedTopOrdering = Just ordering }+        return ordering++-- | Return the operator for a node id.+operator :: Dag.Operator o => AlgNode -> Rewrite o e o+operator n =+  R $ do+    d <- gets dag+    return $ Dag.operator n d++operatorSafe :: AlgNode -> Rewrite o e (Maybe o)+operatorSafe n =+  R $ do+    d <- gets dag+    return $ IM.lookup n (Dag.nodeMap d)++-- | Returns the root nodes of the DAG.+rootNodes :: Rewrite o e [AlgNode]+rootNodes = R $ liftM Dag.rootNodes $ liftM dag $ get++-- | Exposes the current state of the DAG+exposeDag :: Rewrite o e (Dag.AlgebraDag o)+exposeDag = R $ gets dag++getExtras :: Rewrite o e e+getExtras = R $ gets extras++-- | Preserve the effects of a rewrite only if the rewrite signals+-- success by returning True. Otherwise, the state before the rewrite+-- is put in place again.+condRewrite :: Rewrite o e Bool -> Rewrite o e Bool+condRewrite r =+  R $ do+      s       <- get+      success <- unwrapR r+      if success+          then return success+          else trace "Rollback" $ put s >> return success++updateExtras :: e -> Rewrite o e ()+updateExtras e =+  R $ do+    s <- get+    put $ s { extras = e }++-- | Insert an operator into the DAG and return its node id. If the operator is already+-- present (same op, same children), reuse it.+insert :: (Dag.Operator o, Show o) => o -> Rewrite o e AlgNode+insert op =+  R $ do+    d <- gets dag+    unwrapR invalidateCacheM+    let (n, d') = Dag.insert op d+    unwrapR $ putDag d'+    return n++-- | Insert an operator into the DAG and return its node id WITHOUT reusing an+-- operator if it is already present.+insertNoShare :: Dag.Operator o => o -> Rewrite o e AlgNode+insertNoShare op =+  R $ do+    d <- gets dag+    unwrapR invalidateCacheM+    let (n, d') = Dag.insertNoShare op d+    unwrapR $ putDag d'+    return n++-- | replaceChildM n old new replaces all links from node n to node old with links+--   to node new+replaceChild :: Dag.Operator o => AlgNode -> AlgNode -> AlgNode -> Rewrite o e ()+replaceChild n old new =+  R $ do+    s <- get+    unwrapR invalidateCacheM+    unwrapR $ putDag $ Dag.replaceChild n old new $ dag s++-- | replace old new replaces _all_ links to old with links to new+replace :: Dag.Operator o => AlgNode -> AlgNode -> Rewrite o e ()+replace old new = do+  ps <- parents old+  forM_ ps $ (\p -> replaceChild p old new)+  addCollectNode old+  R $ do s <- get+         unwrapR $ putDag $ Dag.replaceRoot (dag s) old new++-- | Creates a new node from the operator and replaces the old node with it+-- by rewiring all links to the old node.+replaceWithNew :: (Dag.Operator o, Show o) => AlgNode -> o -> Rewrite o e AlgNode+replaceWithNew oldNode newOp = do+  newNode <- insert newOp+  replace oldNode newNode+  return newNode++-- | Apply a pure function to the DAG.+infer :: (Dag.AlgebraDag o -> b) -> Rewrite o e b+infer f = R $ liftM f $ gets dag++addCollectNode :: AlgNode -> Rewrite o e ()+addCollectNode n =+  R $ do+    s <- get+    put $ s { collectNodes = S.insert n $ collectNodes s }++collect :: (Show o, Dag.Operator o) => Rewrite o e ()+collect =+  R $ do+    s <- get+    let d' = Dag.collect (collectNodes s) (dag s)+    put s { dag = d', collectNodes = S.empty }++replaceRoot :: Dag.Operator o => AlgNode -> AlgNode -> Rewrite o e ()+replaceRoot oldRoot newRoot =+  R $ do+    s <- get+    if not $ IM.member newRoot $ Dag.nodeMap $ dag s+      then error "replaceRootM: new root node is not present in the DAG"+      else unwrapR $ putDag $ Dag.replaceRoot (dag s) oldRoot newRoot+
+ src/Database/Algebra/Rewrite/Match.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Pattern matches on algebra plans.+module Database.Algebra.Rewrite.Match+    ( Match(..)+    , runMatch+    , getParents+    , getOperator+    , hasPath+    , getRootNodes+    , predicate+    , try+    , matchOp+    , lookupExtras+    , exposeEnv+    , properties+    ) where++import qualified Data.IntMap                 as M++import           Control.Applicative+import           Control.Monad.Reader+import           Control.Monad.Trans.Maybe++import qualified Database.Algebra.Dag        as Dag+import           Database.Algebra.Dag.Common++data Env o p e = Env { dag :: Dag.AlgebraDag o+                     , propMap :: NodeMap p+                     , extras :: e }++-- | The Match monad models the failing of a match and provides+-- limited read-only access to the DAG.+newtype Match o p e a = M (MaybeT (Reader (Env o p e)) a) deriving (Monad, Functor, Applicative)++-- | Runs a match on the supplied DAG. If the Match fails, 'Nothing'+-- is returned.  If the Match succeeds, it returns just the result.+runMatch :: e -> Dag.AlgebraDag o -> NodeMap p -> Match o p e a -> Maybe a+runMatch e d pm (M match) = runReader (runMaybeT match) env+  where env = Env { dag = d, propMap = pm, extras = e }++-- | Returns the parents of a node in a Match context.+getParents :: AlgNode -> Match o p e [AlgNode]+getParents q = do+  M $ asks ((Dag.parents q) . dag)++getOperator :: Dag.Operator o => AlgNode -> Match o p e o+getOperator q = M $ asks ((Dag.operator q) . dag)++hasPath :: AlgNode -> AlgNode -> Match o p e Bool+hasPath q1 q2 = M $ asks ((Dag.hasPath q1 q2) . dag)++getRootNodes :: Match o p e [AlgNode]+getRootNodes = M $ asks (Dag.rootNodes . dag)++-- | Fails the complete match if the predicate is False.+predicate :: Bool -> Match o p e ()+predicate True    = M $ return ()+predicate False   = M $ fail ""++-- | Fails the complete match if the value is Nothing+try :: Maybe a -> Match o p e a+try (Just x) = return x+try Nothing  = fail ""++-- | Runs the supplied Match action on the operator that belongs to+-- the given node.+matchOp :: Dag.Operator o => AlgNode -> (o -> Match o p e a) -> Match o p e a+matchOp q match = M $ asks ((Dag.operator q) . dag) >>= (\o -> unwrap $ match o)+  where unwrap (M r) = r++-- | Look up the properties for a given node.+properties :: AlgNode -> Match o p e p+properties q = do+  M $ do+    pm <- asks propMap+    case M.lookup q pm of+      Just p -> return p+      Nothing -> error $ "Match.properties: no properties for node " ++ (show q)++lookupExtras :: Match o p e e+lookupExtras = M $ asks extras++exposeEnv :: Match o p e (Dag.AlgebraDag o, NodeMap p, e)+exposeEnv = M $ do+  env <- ask+  return (dag env, propMap env, extras env)
+ src/Database/Algebra/Rewrite/PatternConstruction.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Algebra.Rewrite.PatternConstruction+    ( dagPatMatch+    , v +    ) where++import           Control.Applicative+import           Control.Monad.Writer+import           Data.Maybe+import           Language.Haskell.TH++import           Database.Algebra.Dag+import           Database.Algebra.Dag.Common+import qualified Database.Algebra.Rewrite.DagRewrite    as R+import qualified Database.Algebra.Rewrite.Match         as M+import           Database.Algebra.Rewrite.PatternSyntax++type Code a = WriterT [Q Stmt] Q a++emit :: Q Stmt -> Code ()+emit s = tell [s]++matchOp :: Name+matchOp = mkName "matchOp"++opName :: Name+opName = mkName "op__internal"++terOpName :: Name+terOpName = mkName "TerOp"++binOpName :: Name+binOpName = mkName "BinOp"++unOpName :: Name+unOpName = mkName "UnOp"++nullOpName :: Name+nullOpName = mkName "NullaryOp"++failName :: Name+failName = mkName "fail"++catchAllCase :: Q Match+catchAllCase = match wildP (normalB (appE (varE failName) (litE (stringL "")))) []++data SemPattern = Bind (Q Pat, Name)+                | NoBind+                | NoSemantics++-- case op of ... -> return _ -> fail ""+instMatchCase :: Name           -- ^ The name of the node constructor (BinOp, UnOp, NullOp)+                 -> [Name]      -- ^ The name of the operator constructors+                 -> SemPattern -- ^ If the semantical pattern is not a wildcard: the name of the binding variable+                 -> [Q Pat]     -- ^ The list of patterns matching the node children+                 -> [Name]      -- ^ The list of variables for the children (may be empty)+                 -> Bool        -- ^ Bind the operator name (or don't)+                 -> Q Exp       -- ^ Returns the case expression+instMatchCase nodeConstructor opConstructors semantics childMatchPatterns childNames bindOp =+  caseE (varE opName) ((map opAlternative opConstructors) ++ [catchAllCase])+  where opAlternative opConstructor = match opPattern opBody []+          where (semPat, semName) = case semantics of+                  Bind (p, n) -> ([p], [n])+                  NoBind      -> ([wildP], [])+                  NoSemantics -> ([], [])+                opPattern = conP nodeConstructor ((conP opConstructor semPat) : childMatchPatterns)+                opConstExp = if bindOp then [conE opConstructor] else []+                opBody = normalB $ appE (varE (mkName "return")) (tupE $ opConstExp ++ (map varE (semName ++ childNames)))++-- \op -> case op of...+instMatchLambda :: Q Exp -> Q Exp+instMatchLambda body = lam1E (varP opName) body++instMatchExp :: Name -> Q Exp -> Q Exp+instMatchExp nodeName matchLambda =+  appE (appE (varE matchOp) (varE nodeName)) matchLambda++-- (a, b, c) <- ...+instBindingPattern :: Maybe (Q Pat) -> SemPattern -> [Q Pat] -> Q Pat+instBindingPattern mOpConstPat semPat childPats = tupP patterns+  where patterns = (maybeList mOpConstPat) ++ (semList semPat) ++ childPats+        maybeList (Just x) = [x]+        maybeList Nothing  = []++        semList (Bind (pat, _)) = [pat]+        semList NoBind         = []+        semList NoSemantics    = []++-- (a, b, c) <- matchOp q (\op -> case op of ...)+instStatement :: Maybe (Q Pat) -> SemPattern -> [Q Pat] -> Q Exp -> Q Stmt+instStatement mOpConstPat semPat childPats matchExp =+  case (semPat, childPats) of+    (NoBind, [])      -> noBindS matchExp+    (NoSemantics, []) -> noBindS matchExp+    (_, _)            -> bindS (instBindingPattern mOpConstPat semPat childPats) matchExp++semPatternName :: Maybe Sem -> SemPattern+semPatternName (Just WildS)      = NoBind+semPatternName (Just (NamedS s)) = let name = mkName s in Bind (varP name, name)+semPatternName Nothing           = NoSemantics++instStmtWrapper :: Name              -- ^ The name of the node on which to match+                   -> Name           -- ^ The name of the node constructor (BinOp, UnOp, NullOp)+                   -> [Name]         -- ^ The name of the operator constructors+                   -> Maybe (Q Pat)  -- ^ The binding name for the operator constructor+                   -> SemPattern     -- ^ Pattern binding the semantical information (or wildcard)+                   -> [Q Pat]        -- ^ The list of patterns matching the node children+                   -> [Q Pat]        -- ^ The list of patterns binding the node children (may be empty)+                   -> [Name]         -- ^ The list of variables for the children (may be empty)+                   -> Q Stmt         -- ^ Returns the case expression+instStmtWrapper nodeName nodeKind operNames mOpConstPat semantics childMatchPats childPats childNames =+  let matchCase   = instMatchCase nodeKind operNames semantics childMatchPats childNames (isJust mOpConstPat)+      matchLambda = instMatchLambda matchCase+      matchExp    = instMatchExp nodeName matchLambda+  in instStatement mOpConstPat semantics childPats matchExp++opInfo :: Op -> (Maybe (Q Pat), [Name])+opInfo (NamedOp bindingName opNames) = (Just $ varP $ mkName bindingName, map mkName opNames)+opInfo (UnnamedOp opNames) = (Nothing, map mkName opNames)++-- generate a list of node matching statements from an operator (tree)+gen :: Name -> Node -> Code ()+gen nodeName (NullP op semBinding) =+  let semantics = semPatternName semBinding+      (mOpConstPat, opNames) = opInfo op+      statement = instStmtWrapper nodeName nullOpName opNames mOpConstPat semantics [] [] []+  in emit statement++gen nodeName (UnP op semBinding child) = do+  let semantics = semPatternName semBinding+      (mOpConstPat, opNames) = opInfo op++  patAndName <- lift (childMatchPattern child)++  let (matchPatterns, bindNames, bindPatterns) = splitMatchAndBind $ [patAndName]+      statement = instStmtWrapper nodeName unOpName opNames mOpConstPat semantics matchPatterns bindPatterns bindNames++  emit statement++  maybeDescend child (snd patAndName)++gen nodeName (BinP op semBinding child1 child2) = do+  let semantics = semPatternName semBinding+      (mOpConstPat, opNames) = opInfo op++  leftPatAndName   <- lift (childMatchPattern child1)+  rightPatAndName  <- lift (childMatchPattern child2)++  let (matchPatterns, bindNames, bindPatterns) = splitMatchAndBind [leftPatAndName, rightPatAndName]+      statement = instStmtWrapper nodeName binOpName opNames mOpConstPat semantics matchPatterns bindPatterns bindNames++  emit statement++  maybeDescend child1 (snd leftPatAndName)+  maybeDescend child2 (snd rightPatAndName)++gen nodeName (TerP op semBinding child1 child2 child3) = do+  let semantics = semPatternName semBinding+      (mOpConstPat, opNames) = opInfo op++  patAndName1 <- lift (childMatchPattern child1)+  patAndName2 <- lift (childMatchPattern child2)+  patAndName3 <- lift (childMatchPattern child3)++  let childPatAndNames = [patAndName1, patAndName2, patAndName3]+      (matchPatterns, bindNames, bindPatterns) = splitMatchAndBind $ childPatAndNames+      statement = instStmtWrapper nodeName terOpName opNames mOpConstPat semantics matchPatterns bindPatterns bindNames++  emit statement++  maybeDescend child1 (snd patAndName1)+  maybeDescend child2 (snd patAndName2)+  maybeDescend child3 (snd patAndName3)++gen nodeName (HoleP holeStart subHolePat) = do+  -- collect all binders from the sub-hole pattern in a canonical order+  let binderNames = map mkName $ collectBinders subHolePat++  -- generate a function that tries to match the sub-hole pattern at the given node+  (patMatchFunName, patMatchFunStmt) <- lift $ genSubHoleMatch binderNames subHolePat+  emit patMatchFunStmt++  -- (nodeName, binderNames) <- searchHolePat patMatchName holeStart+  -- Use function searchHolePat to search for a node at which the sub-hole+  -- pattern matches.+  let searchExpr = appE (appE (varE 'searchHolePat) (varE patMatchFunName)) (varE nodeName)+      bindingPat = tupP [varP (mkName holeStart), listP (map varP binderNames)]++  emit $ bindS bindingPat searchExpr++gen nodeName (HoleEq eqNode) = do+  emit $ noBindS $ appE (appE (varE 'searchHoleEq) (varE nodeName)) (varE $ mkName eqNode)++-- Traverse a DAG (DFS, preorder) and search for a node where the given pattern applies.+-- Returns the matching node and the list of values for the pattern's binders.+searchHolePat :: Operator o+                 => (AlgNode -> M.Match o p e [AlgNode])+                 -> AlgNode+                 -> M.Match o p e (AlgNode, [AlgNode])+searchHolePat patMatch q = do+  (d, p, e) <- M.exposeEnv+  case M.runMatch e d p (patMatch q) of+    Just nodes -> return (q, nodes)+    Nothing    -> do+                    children <- opChildren <$> M.getOperator q+                    searchChildren patMatch children++-- Apply searchHolePat to a list of nodes, take the first one that matches.+searchChildren :: Operator o+                  => (AlgNode -> M.Match o p e [AlgNode])+                  -> [AlgNode]+                  -> M.Match o p e (AlgNode, [AlgNode])+searchChildren _        []     = fail "no match"+searchChildren patMatch (q:qs) = do+  (d, p, e) <- M.exposeEnv+  case M.runMatch e d p(searchHolePat patMatch q) of+    Just nodes -> return nodes+    Nothing    -> searchChildren patMatch qs++-- Search for an occurence of the node 'eqNode', starting at 'startNode'+searchHoleEq :: Operator o => AlgNode -> AlgNode -> M.Match o p e ()+searchHoleEq startNode eqNode =+  if startNode == eqNode+  then return ()+  else do+    (d, _, _) <- M.exposeEnv+    children <- opChildren <$> M.getOperator startNode+    if nodeOccurs d eqNode children+      then return ()+      else fail "no occurence"++-- Since we only search for occurences of a particular node and no pattern matching+-- occurs, we do not burden ourselves with the Match monad here.+nodeOccurs :: Operator o => AlgebraDag o -> AlgNode -> [AlgNode] -> Bool+nodeOccurs dag eqNode startNodes =+  if eqNode `elem` startNodes+  then True+  else or $ map (nodeOccurs dag eqNode . opChildren . (flip operator dag)) startNodes++-- | Generate a function which matches a pattern on a certain node.+-- The generated function returns values for all binders in the pattern+-- in the canonical order given by 'binderNames'+-- Type of the generated function:+--      subhole_xy :: AlgNode -> Match o [AlgNode]+genSubHoleMatch :: [Name] -> Pattern -> Q (Name, Q Stmt)+genSubHoleMatch binderNames pat = do+  -- generate the code for matching the pattern+  rootName <- newName "subNode"+  patternStatements <- execWriterT $ gen rootName pat+  -- return values for the binders in the proper order.+  let returnStatement   = noBindS $ appE (varE 'return) (listE $ map varE binderNames)+      body              = doE $ patternStatements ++ [returnStatement]++  -- the function binding+  funName <- newName "subhole"+  let fun  = funD funName [(clause [varP rootName] (normalB body) [])]+      stmt = letS $ [fun]+  return (funName, stmt)++{-+semBinder :: Maybe Sem -> [Ident]+semBinder (Just (NamedS i)) = [i]+semBinder (Just WildS)      = []+semBinder Nothing           = []+-}++opBinder :: Op -> [Ident]+opBinder (NamedOp i _) = [i]+opBinder (UnnamedOp _) = []++childBinders :: Child -> [Ident]+childBinders (NodeC n)        = collectBinders n+childBinders WildC            = []+childBinders (NameC i)        = [i]+childBinders (NamedNodeC i n) = i : collectBinders n++-- Collect binders in pre-order fashion from a pattern tree+-- TODO: so far, only binders for nodes (type AlgNode) are collected. This is+-- necessary so that we can return values for them in a list without type-specific+-- wrappers+collectBinders :: Node -> [Ident]+collectBinders (TerP op _ c1 c2 c3) = opBinder op+                                      -- ++ semBinder sem+                                      ++ concatMap childBinders [c1, c2, c3]+collectBinders (BinP op _ c1 c2)    = opBinder op+                                      -- ++ semBinder sem+                                      ++ concatMap childBinders [c1, c2]+collectBinders (UnP op _ c)         = opBinder op+                                      -- ++ semBinder sem+                                      ++ childBinders c+collectBinders (NullP op _)         = opBinder op -- ++ semBinder sem+collectBinders (HoleP _ _)          = error "collectBinders: Holes in sub-hole patterns not supported"+collectBinders (HoleEq _)           = []++{-+Split the list of matching patterns and binding names.+-}+splitMatchAndBind :: [(Q Pat, Maybe Name)] -> ([Q Pat], [Name], [Q Pat])+splitMatchAndBind ps =+  let (matchPatterns, mBindNames) = unzip ps+      bindNames = catMaybes mBindNames+  in (matchPatterns, bindNames, map varP bindNames)++{-+For every child, generate the matching pattern and - if the child+is to be bound either with a given name or for matching on the child itself -+the name to which it should be bound.++This distinction is necessary because a child that is not to be bound+must be matched anyway with a wildcard pattern so that the operator constructor+has enough parameters in the match.+-}+childMatchPattern :: Child -> Q (Q Pat, Maybe Name)+childMatchPattern WildC   =+  return (wildP, Nothing)+childMatchPattern (NameC s) =+  let n = mkName s+  in return (varP n, Just n)+childMatchPattern (NodeC _) =+  newName "child"+  >>= (\n -> return (varP n, Just n))+childMatchPattern (NamedNodeC s _) =+  let n = mkName s+  in return (varP n, Just n)++recurse :: Child -> Maybe Node+recurse WildC           = Nothing+recurse (NameC _)       = Nothing+recurse (NodeC o)         = Just o+recurse (NamedNodeC _ o ) = Just o++maybeDescend :: Child -> Maybe Name -> Code ()+maybeDescend c ns =+  case recurse c of+    Just o   ->+      case ns of+        Just n   -> gen n o+        Nothing  -> error "PatternConstruction.gen: no name for child pattern"+    Nothing  -> return ()++assembleStatements :: Q [Stmt] -> Q Exp -> Q Exp+assembleStatements patternStatements userExpr = do+  ps <- patternStatements+  e <- userExpr++  let us =+        case e of+          DoE userStatements -> userStatements+          _ -> error "PatternConstruction.assembleStatements: no do-block supplied"++      -- The call to collect+      collectStmt = NoBindS $ VarE 'R.collect++      -- Extract the returned sequence of rewrite actions and patch the+      -- call to collect at the end+      returnStmt = case last us of+                     NoBindS (InfixE (Just (VarE returnName)) (VarE dollarName) (Just rewriteExpr))+                       | dollarName == '($) && returnName == 'return    ->+                         let rewriteExpr' = DoE [NoBindS rewriteExpr, collectStmt]+                         in NoBindS (InfixE (Just (VarE returnName)) (VarE dollarName) (Just rewriteExpr'))+                     s                                                  -> error $ show s++      -- reassemble the user statements+      us' = init us ++ [returnStmt]++  -- Return a do block consisting of the pattern statements and the user statements.+  return $ DoE $ ps ++ us'++-- | Take a quoted variable with the root node on which to apply the pattern,+-- a string description of the pattern and the body of the match+-- and return the complete match statement. The body has to be a quoted ([| ...|])+-- do-block.+dagPatMatch :: Name -> String -> Q Exp -> Q Exp+dagPatMatch rootName patternString userExpr = do++  let pat = parsePattern patternString++  -- generate the code that matches the pattern (a list of statements)+  patternStatements <- execWriterT $ gen rootName pat++  -- combine the generated pattern-matching statements with the+  -- user-supplied additional predicates+  assembleStatements (mapM id patternStatements) userExpr++-- | Reference a variable that is bound by a pattern in a quoted match body.+v :: String -> Q Exp+v = dyn
+ src/Database/Algebra/Rewrite/PatternSyntax.hs view
@@ -0,0 +1,172 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Database.Algebra.Rewrite.PatternSyntax +    ( Pattern+    , Op(..)+    , Node(..)+    , Child(..)+    , Sem(..)+    , Ident+    , UIdent+    , parsePattern+    ) where++import Text.ParserCombinators.Parsec++{-++S -> Op++Node    -> (Child) Op Sem (Child)+        |  Op Sem (Child)+        |  Op Sem++Op      -> Alternative+        | Id @ Alternative+        | Uid++Child -> _+      |  Op+      |  Id = Op ++Sem   -> _+      |  Id++-}++type Pattern = Node++data Node = TerP Op (Maybe Sem) Child Child Child+          | BinP Op (Maybe Sem) Child Child+          | UnP Op (Maybe Sem) Child+          | NullP Op (Maybe Sem)+          | HoleP Ident Node+          | HoleEq Ident+          deriving Show+           +data Child = NodeC Node+           | WildC+           | NameC Ident+           | NamedNodeC Ident Node+           deriving Show+             +data Sem = NamedS Ident+         | WildS+         deriving (Show, Eq)+                  +data Op = NamedOp Ident [UIdent]+        | UnnamedOp [UIdent]+          deriving Show+             +type Ident = String+             +type UIdent = String+              +pattern :: Parser Pattern+pattern = node+          +node :: Parser Node+node = do { c1 <- enclosed child+          ; space+          ; ops <- operator+          ; space+          ; info <- optionMaybe sem+          ; c2 <- enclosed child +          ; return $ BinP ops info c1 c2 }++       <|> try (do { ops <- operator+                   ; space+                   ; info <- optionMaybe sem+                   ; c1 <- enclosed child+                   ; space+                   ; c2 <- enclosed child+                   ; space+                   ; c3 <- enclosed child+                   ; return $ TerP ops info c1 c2 c3 })++       <|> try (do { ops <- operator+                   ; space+                   ; info <- optionMaybe sem+                   ; c <- enclosed child+                   ; return $ UnP ops info c })++       <|> try (do { ops <- operator+                   ; space+                   ; info <- optionMaybe sem+                   ; return $ NullP ops info })++       <|> try (do { string "{ }"+                   ; space+                   ; name <- ident+                   ; char '='+                   ; n <- node+                   ; return $ HoleP name n })+       <|> do { string "{ }"+              ; space+              ; string "eq"+              ; name <- enclosed ident+              ; return $ HoleEq name+              }+       +altSep :: Parser ()+altSep = space >> char '|' >> space >> return ()+         +-- [Op1 | Op2 | ...]+altOps :: Parser [UIdent]+altOps = do { char '['+            ; ops <- sepBy1 uident altSep+            ; char ']'+            ; return ops }+       +operator :: Parser Op+operator = try (do { ops <- altOps+                   ; char '@'+                   ; name <- ident+                   ; return $ NamedOp name ops })+           <|> do { ops <- altOps+                  ; return $ UnnamedOp ops }+           <|> do { op <- uident+                  ; return $ UnnamedOp [op] }+  +enclosed :: Parser a -> Parser a+enclosed p = do+  char '('+  r <- p+  char ')'+  return r++uident :: Parser UIdent+uident = do+  first <- upper+  rest <- many alphaNum+  return $ first : rest++ident :: Parser Ident+ident = do+  first <- lower+  rest <- many alphaNum+  return $ first : rest++child :: Parser Child+child = do { n <- node; return $ NodeC n }+        <|> do { wildcard; return WildC }+        <|> (try (do { name <- ident+                     ; char '='+                     ; n <- node +                     ; return $ NamedNodeC name n }))+        <|> do { name <- ident; return $ NameC name }+        +wildcard :: Parser ()+wildcard = do+  char '_'+  return ()+           +sem :: Parser Sem+sem = do { s <- ident; space; return $ NamedS s }+      <|> do { wildcard; space; return $ WildS }+      +parsePattern :: String -> Pattern+parsePattern s = +  case parse pattern "" s of+    Left e -> error $ "Parsing failed: " ++ (show e)+    Right p -> p
+ src/Database/Algebra/Rewrite/Properties.hs view
@@ -0,0 +1,41 @@+module Database.Algebra.Rewrite.Properties(inferBottomUpGeneral) where++import           Control.Monad.Reader+import           Control.Monad.State+import qualified Data.IntMap                 as M+import           Database.Algebra.Dag+import           Database.Algebra.Dag.Common++-- | Inference of bottom up properties p over a DAG of operator type o.+type Inference p o a = StateT (NodeMap p) (Reader (AlgebraDag o)) a++hasBeenVisited :: AlgNode -> Inference p o Bool+hasBeenVisited n = do+  pm <- get+  return $ M.member n pm++putProperty :: AlgNode -> p -> Inference p o ()+putProperty n p = do+  pm <- get+  put $ M.insert n p pm+++traverse :: (Show o, Operator o) => (NodeMap o -> o -> AlgNode -> NodeMap p -> p) -> AlgNode -> Inference p o ()+traverse inferWorker n = do+  visited <- hasBeenVisited n+  if visited+    then return ()+    else do+      dag <- lift ask+      let op = operator n dag+      mapM_ (traverse inferWorker) (opChildren op)+      pm <- get+      putProperty n (inferWorker (nodeMap dag) op n pm)++-- | Infer bottom up properties with the given inference function.+inferBottomUpGeneral :: Operator o+                        => (NodeMap o -> o -> AlgNode -> NodeMap p -> p)  -- ^ Function that infers properties for a single node+                        -> AlgebraDag o                   -- ^ The DAG+                        -> NodeMap p                      -- ^ The final mapping from nodes to properties+inferBottomUpGeneral inferWorker dag = runReader (execStateT infer M.empty) dag+  where infer = mapM_ (traverse inferWorker) (rootNodes dag)
+ src/Database/Algebra/Rewrite/Rule.hs view
@@ -0,0 +1,26 @@+module Database.Algebra.Rewrite.Rule+       ( Rule+       , RuleSet+       , applyRuleSet ) where++import Database.Algebra.Dag.Common+import Database.Algebra.Rewrite.DagRewrite+import Database.Algebra.Rewrite.Match++type Rule o p e = AlgNode -> Match o p e (Rewrite o e ())+              +type RuleSet o p e = [Rule o p e]++-- | Try a set of rules on a node and apply the rewrite of the first+-- rule that matches.+applyRuleSet :: e -> NodeMap p -> RuleSet o p e -> AlgNode -> Rewrite o e Bool+applyRuleSet e pm rules q = do+  d <- exposeDag+  +  let aux []        = return False+      aux (rule:rs) = case runMatch e d pm (rule q) of+                          Just rewrite -> rewrite >> return True+                          Nothing      -> aux rs+      +  aux rules+
+ src/Database/Algebra/Rewrite/Traversal.hs view
@@ -0,0 +1,172 @@+module Database.Algebra.Rewrite.Traversal+       ( preOrder+       , postOrder+       , applyToAll+       , topologically+       , iteratively+       , sequenceRewrites+       ) where++import           Control.Applicative+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+          -- drop the first nodes, assuming that we already visited them+          nodes <- drop offset <$> M.keys <$> Dag.nodeMap <$> exposeDag++          -- re-infer properties+          props <- inferProps++          extras <- getExtras++          -- try to apply the rewrites, beginning with node at position offset+          matchedOffset <- traverseNodes offset props extras rules nodes++          case matchedOffset of+            -- A rewrite applied at offset o -> we continue at this offset+            Just o -> iterateRewrites True o+            -- No rewrite applied -> report if any changes occured at all+            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++-- | Infer properties, then traverse the DAG in preorder fashion and apply the rule set+-- at every node. Properties are re-inferred after every change.+preOrder :: Dag.Operator o+            => Rewrite o e (NodeMap p)+            -> RuleSet o p e+            -> Rewrite o e Bool+preOrder inferAction rules =+  let traverse (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+++          -- Have to be careful here: With garbage collection, the current node 'q'+          -- might no longer be present after a rewrite.+          mop <- operatorSafe q+          case mop of+            Just op -> do+              -- the node still seems to be around, so we need to look after its children+              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) -- The node has been collected -> do nothing++      descend (changedPrev, mProps, visited) c = do+          props <- case mProps of+            Just ps -> return ps+            Nothing -> inferAction+          traverse (changedPrev, Just props, visited) c++  in do+    pm <- inferAction+    rs <- rootNodes+    (changed, _, _) <- foldM traverse (False, Just pm, S.empty) rs+    return changed++{- | Map a ruleset over the nodes of a DAG in topological order. This function assumes that+     the structur of the DAG is not changed during the rewrites. Properties are only inferred+     once.+-}+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++-- | Infer properties, then traverse the DAG in a postorder fashion and apply the rule set at+-- every node. Properties are re-inferred after every change.+postOrder :: Dag.Operator o+             => Rewrite o e (NodeMap p)+             -> RuleSet o p e+             -> Rewrite o e Bool+postOrder inferAction rules =+  let traverse (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++          -- Check if the current node is still around after its children+          -- have been rewritten. This should not happen regularly, but+          -- better safe than sorry.+          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+          traverse (changedPrev, Just props, visited) c++  in do+    pm <- inferAction+    rs <- rootNodes+    (changed, _, _) <- foldM traverse (False, Just pm, S.empty) rs+    return changed++-- | Iteratively apply a rewrite, until no further changes occur.+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++-- | Sequence a list of rewrites and propagate information about+-- wether one of them applied.+sequenceRewrites :: [Rewrite o e Bool] -> Rewrite o e Bool+sequenceRewrites rewrites = or <$> sequence rewrites