algebra-sql (empty) → 0.1.0.0
raw patch · 27 files changed
+4784/−0 lines, 27 filesdep +aesondep +algebra-dagdep +ansi-wl-pprintsetup-changed
Dependencies added: aeson, algebra-dag, ansi-wl-pprint, base, bytestring, containers, dlist, errors, fgl, filepath, ghc-prim, mtl, multiset, parsec, pretty, process, template-haskell, transformers
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- algebra-sql.cabal +99/−0
- src/Database/Algebra/Impossible.hs +18/−0
- src/Database/Algebra/SQL/Compatibility.hs +13/−0
- src/Database/Algebra/SQL/Materialization.hs +18/−0
- src/Database/Algebra/SQL/Materialization/CTE.hs +137/−0
- src/Database/Algebra/SQL/Materialization/Combined.hs +274/−0
- src/Database/Algebra/SQL/Materialization/Graph.hs +56/−0
- src/Database/Algebra/SQL/Materialization/TemporaryTable.hs +24/−0
- src/Database/Algebra/SQL/Materialization/Util.hs +23/−0
- src/Database/Algebra/SQL/Query.hs +333/−0
- src/Database/Algebra/SQL/Query/Substitution.hs +179/−0
- src/Database/Algebra/SQL/Query/Util.hs +80/−0
- src/Database/Algebra/SQL/Render.hs +49/−0
- src/Database/Algebra/SQL/Render/Query.hs +440/−0
- src/Database/Algebra/SQL/Render/Tile.hs +75/−0
- src/Database/Algebra/SQL/Termination.hs +108/−0
- src/Database/Algebra/SQL/Tile.hs +1028/−0
- src/Database/Algebra/SQL/Tile/Flatten.hs +138/−0
- src/Database/Algebra/SQL/Tools/Gen.hs +489/−0
- src/Database/Algebra/SQL/Util.hs +98/−0
- src/Database/Algebra/Table/Construct.hs +225/−0
- src/Database/Algebra/Table/Lang.hs +336/−0
- src/Database/Algebra/Table/Render/Dot.hs +371/−0
- src/Database/Algebra/Table/Render/JSON.hs +83/−0
- src/Database/Algebra/Table/Tools/DotGen.hs +61/−0
+ 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-sql.cabal view
@@ -0,0 +1,99 @@+cabal-version: >=1.8+Name: algebra-sql+synopsis: Relational Algebra and SQL Code Generation+Category: Database+Version: 0.1.0.0+Description: This library contains data types for relational table algebra operators. DAG plans+ (<http://hackage.haskell.org/package/algebra-dag algebra-dag>) over these operators+ can be compiled into compact SQL:2003 queries.+License: BSD3+License-file: LICENSE+Author: Alexander Ulrich, Moritz Bruder+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, + pretty >= 1.1, + fgl >= 5.5, + transformers >= 0.3, + parsec >= 3.1,+ ghc-prim >= 0.3,+ bytestring >= 0.10,+ errors >= 1.0,+ dlist >= 0.7,+ ansi-wl-pprint >= 0.6,+ multiset >= 0.2,+ aeson >= 0.8,+ algebra-dag >= 0.1++ exposed-modules: Database.Algebra.Table.Render.Dot+ Database.Algebra.Table.Render.JSON+ Database.Algebra.Table.Lang+ Database.Algebra.Table.Construct++ Database.Algebra.SQL.Util+ Database.Algebra.SQL.Compatibility+ Database.Algebra.SQL.Materialization+ Database.Algebra.SQL.Materialization.CTE+ Database.Algebra.SQL.Materialization.Combined++ hs-source-dirs: src+ GHC-Options: -Wall -fno-warn-orphans+ other-modules: Database.Algebra.SQL.Query+ Database.Algebra.SQL.Query.Substitution+ Database.Algebra.SQL.Query.Util+ Database.Algebra.SQL.Termination+ Database.Algebra.SQL.Tile+ Database.Algebra.SQL.Tile.Flatten+ Database.Algebra.SQL.Render+ Database.Algebra.SQL.Render.Tile+ Database.Algebra.SQL.Render.Query+ Database.Algebra.SQL.Materialization.Graph+ Database.Algebra.SQL.Materialization.Util+ Database.Algebra.SQL.Materialization.TemporaryTable+ Database.Algebra.Impossible++executable tadot+ Main-is: Database/Algebra/Table/Tools/DotGen.hs+ GHC-Options: -Wall -fno-warn-orphans+ hs-source-dirs: src+ build-depends: base >= 4.7 && < 5, + mtl >= 2.1, + containers >= 0.5, + template-haskell >= 2.9, + pretty >= 1.1, + fgl >= 5.5, + transformers >= 0.3, + parsec >= 3.1,+ ghc-prim >= 0.3,+ bytestring >= 0.10,+ aeson >= 0.8,+ algebra-dag >= 0.1++executable sqlgen+ Main-is: Database/Algebra/SQL/Tools/Gen.hs+ GHC-Options: -Wall -fno-warn-orphans+ hs-source-dirs: src+ build-depends: base >= 4.7 && < 5, + mtl >= 2.1, + containers >= 0.5, + template-haskell >= 2.9, + pretty >= 1.1, + fgl >= 5.5, + filepath >= 1.3,+ process >= 1.2,+ transformers >= 0.3, + parsec >= 3.1,+ ghc-prim >= 0.3,+ bytestring >= 0.10,+ errors >= 1.0,+ dlist >= 0.7,+ ansi-wl-pprint >= 0.6,+ multiset >= 0.2,+ aeson >= 0.8,+ algebra-dag >= 0.1
+ src/Database/Algebra/Impossible.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module Database.Algebra.Impossible (impossible, unimplemented) where++import qualified Language.Haskell.TH as TH++impossible :: TH.ExpQ+impossible = do+ loc <- TH.location+ let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))+ let message = "TableAlgebra: Impossible happenend at " ++ show pos+ return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message)))++unimplemented :: TH.ExpQ+unimplemented = do+ loc <- TH.location+ let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))+ let message = "DSH: Unimplemented at " ++ show pos+ return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message)))
+ src/Database/Algebra/SQL/Compatibility.hs view
@@ -0,0 +1,13 @@+-- This module defines compatibility modes, for different SQL dialects.+module Database.Algebra.SQL.Compatibility+ ( CompatMode(..)+ ) where++-- TODO Provide feature specific records, in case this file gets bigger.++-- | Defines the possible modes used for certain tasks like rendering and+-- materialization.+data CompatMode = SQL99+ | PostgreSQL+ | MonetDB+
+ src/Database/Algebra/SQL/Materialization.hs view
@@ -0,0 +1,18 @@+-- Provides a basic toolset for materialization functions.+module Database.Algebra.SQL.Materialization + ( MatFun+ ) where++import Database.Algebra.SQL.Tile (TileTree, DependencyList)+import Database.Algebra.SQL.Query (Query)++-- | The type of materialization function. The result consists of:+--+-- * The queries which need to be executed first+--+-- * The queries produced from the root nodes+--+type MatFun = (([TileTree], DependencyList) -> ([Query], [Query]))+++
+ src/Database/Algebra/SQL/Materialization/CTE.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DoAndIfThenElse #-}+module Database.Algebra.SQL.Materialization.CTE+ ( materialize+ , legacyMaterialize+ ) where++import Control.Monad.State+import Control.Monad.Reader+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import Data.Maybe++import Database.Algebra.SQL.Materialization+import Database.Algebra.SQL.Materialization.Util+import qualified Database.Algebra.SQL.Materialization.Graph as G+import Database.Algebra.SQL.Query+import Database.Algebra.SQL.Tile.Flatten+import Database.Algebra.SQL.Query.Substitution++-- TODO remove after testing+-- | Create a CTE for every root tile and add a binding for every dependency.+legacyMaterialize :: MatFun+legacyMaterialize transformResult =+ ( []+ , if null bindings+ then map (QValueQuery . VQSelect . fst) selects+ else map+ (QValueQuery . VQWith bindings . VQSelect . fst)+ selects+ )+ where bindings = map f deps+ f (name, (body, _)) = (name, Nothing, VQSelect body)++ selects :: [FlatTile String]+ deps :: [(String, FlatTile String)]+ (selects, deps) =+ flattenTransformResult transformResult++-- | 'Gather' provides a state for the current bindings which are gathered and a+-- reader to have access to the set which contains all vertices reachable by the+-- current root vertex.+type Gather = StateT (IntMap.IntMap SelectStmt) (Reader IntSet.IntSet)++materialize :: MatFun+materialize transformResult =+ ( []+ , map (QValueQuery . gather) rootVertices+ )+ where+ (rootTiles, enumDeps) = flattenTransformResultWith id+ FEVariable+ transformResult+ graph = graphFromFlatResult $ enumRootTiles ++ enumDeps+ -- Enumerated root tiles.+ enumRootTiles = zip [-1, -2 ..] rootTiles+ rootVertices = map fst enumRootTiles+++ -- Create a WITH query for a root vertex.+ gather :: G.Vertex -> ValueQuery+ gather v = case mSelect of+ Just (_, s) ->+ if IntMap.null bindings+ then VQSelect s+ else VQWith withQueryBindings $ VQSelect s+ + Nothing -> error "gather: v is not a root vertex"+ where+ withQueryBindings = IntMap.foldrWithKey toBinding [] bindings++ (mSelect, bindings) = runReader (runStateT (visit v) IntMap.empty)+ $ IntSet.fromList $ G.reachable v graph+ + -- TODO factor out+ toBinding ref select l = ('t' : show ref, Nothing, VQSelect select) : l++ -- The return value indicates whether the parent should inline.+ visit :: G.Vertex -> Gather (Maybe (Int, SelectStmt))+ visit v = do++ alreadyBound <- hasBinding v+ + if alreadyBound+ -- Binding already added.+ then return Nothing+ else do++ doInline <- shouldInline v++ allResults <- mapM visit $ G.children v graph++ let -- Get those results which need inlining.+ results = catMaybes allResults+ -- Inline those results into the current label.+ select =+ replaceReferencesSelectStmt+ replace+ (fromMaybe errorMsg $ G.node v graph)+ -- The lookup function used for substitution.+ replace ref = case lookup ref results of+ -- It will be available from the bindings of the with query.+ Nothing -> FETableReference $ 't' : show ref+ -- We will provide it inline.+ Just s -> FESubQuery $ VQSelect s++ errorMsg = error "visit: invalid vertex, no label found"++ if doInline+ then -- Inline this vertex within one or zero parents.+ return $ Just (v, select)+ else do+ -- This vertex is referenced by multiple ones, there is no way+ -- we could inline it.+ addBinding v select++ return Nothing+ + addBinding :: G.Vertex -> SelectStmt -> Gather ()+ addBinding v select =+ modify $ IntMap.insert v select++ hasBinding :: G.Vertex -> Gather Bool+ hasBinding v = gets $ IntMap.member v++ reachableByRoot :: G.Vertex -> Gather Bool+ reachableByRoot v = asks $ IntSet.member v++ shouldInline :: G.Vertex -> Gather Bool+ shouldInline v = do++ knownParents <- filterM reachableByRoot $ G.parents v graph++ return $ case knownParents of+ [] -> True+ -- Has just one known parent.+ [_] -> True+ _ -> False
+ src/Database/Algebra/SQL/Materialization/Combined.hs view
@@ -0,0 +1,274 @@+-- | Materializes tiles which are reachable through multiple root tiles as+-- temporary tables and everything else by using common tables expressions.+-- It is possible to choose the binding strategy for common table expressions:+--+-- * Bind in lowest possible CTE, results in toughest possible scoping,+-- tiles are only bound where they are actually used.+--+-- * Bind in highest possible CTE, tiles are bound at the highest+-- possible CTE, results in very few common table expressions.+--+module Database.Algebra.SQL.Materialization.Combined+ ( BindingStrategy(Lowest, Highest)+ , materialize+ , materializeByBindingStrategy+ ) where++import Control.Monad (when)+import Control.Monad.State.Strict+ ( State+ , gets+ , modify+ , execState+ )+import qualified Data.IntMap.Lazy as IntMap+ ( IntMap+ , alter+ , empty+ , foldrWithKey+ , insert+ , lookup+ )+import qualified Data.List as L (intersect)+import Data.Maybe+ ( fromMaybe+ , isJust+ )++import Database.Algebra.SQL.Materialization+import qualified Database.Algebra.SQL.Materialization.Graph as G+import qualified Database.Algebra.SQL.Query as Q+ ( DefinitionQuery(DQTemporaryTable)+ , FromExpr(FEVariable, FETableReference)+ , Query(QValueQuery, QDefinitionQuery)+ , ValueQuery(VQSelect, VQWith)+ )+import Database.Algebra.SQL.Query.Substitution+import Database.Algebra.SQL.Tile.Flatten+import Database.Algebra.SQL.Materialization.Util++-- TODO maybe replace lists with sets? because difference should be faster+-- TODO since all root tiles are enumerated with negative numbers, the root+-- vertex check could be simply: v < 0 (O(n) -> O(1))+-- TODO in addition to the previous point add this information to the definiton+-- of transform+-- TODO maybe add schemata to the value query builder function++{-+ Definition: Single parent ancestor+ Every vertex v for which |parents(v)| <= 1 is a single parent ancestor+ for every vertex w which can only be reached through paths containing v.++ The single parent ancestors of a vertex u are called spa(u).++ Lemma:+ Let p_1, ..., p_n be parents of v, then the set of single parent+ ancestors is defined as:+ spa(v) = \bigcap_{i = 1, ..., n} spa'(p_i)++ spa'(v) = spa(v) \cup {v}++ Proof: Induction over the vertices++ Hypothesis:++ spa(v) contains all single parent ancestors of v+ <=> \forall u \in spa(v): u is in every path to v++ Basis:+ v has no parents:+ spa(v) = {}++ + spa(v) = {}+ => \forall u \in spa(v): u is in every path to v++ Inductive step:+ v has parents p_1, ..., p_n:+ spa(v) = spa'(p_1) \cap spa'(p_2) \cap ... \cap spa'(p_n)+ = (spa(p_1) \cup {p_1}) \cap ...+ \cap (spa(p_n) \cup {p_n})++ u \in spa(v)+ => u \in ((spa(p_1) \cup {p_1}) \cap ...+ \cap (spa(p_n) \cup {p_n}))++ => u \in (\bigcap_{i = 1, ..., n} {p_i})+ \lor u \in (\bigcap_{i = 1, ..., n} spa(p_i))++ \overline{Inductive hypothesis}{=>}+ \forall u \in spa(v): u is in every path to v++ If n = 1, then the first part of the disjunction will occur,+ and/or the inductive hypothesis is used for the second part.++ Note that vertices contained in maps are always topologically sorted,+ because the transform algorithm generates those by an in-order traversal.+-}++-- | Describes the binding behaviour within a dependency tree.+data BindingStrategy = Lowest | Highest++-- | Merges all tiles reachable by a single root tile into nested common table+-- expressions (depending on their scope) and all tiles reachable by multiple+-- root tiles into a temporary table. The binding strategy determines whether it+-- is merged in the highest possible CTE or in the lowest.+materializeByBindingStrategy :: BindingStrategy -> MatFun+materializeByBindingStrategy bs =+ materializeByFunction $ case bs of+ Lowest -> chooseLowestSPA+ Highest -> chooseHighestSPA++-- | Same as 'materializeByBehaviour' with 'Lowest' as behaviour.+materialize :: MatFun+materialize = materializeByFunction chooseLowestSPA++-- | Merges all tiles reachable by a single root tile into nested common table+-- expressions (depending on their scope) and all tiles reachable by multiple+-- root tiles into a temporary table.+materializeByFunction :: (IntMap.IntMap [G.Vertex] -> IntMap.IntMap [G.Vertex])+ -> MatFun+materializeByFunction chooseSingleSPA transformResult =+ queriesFromSPA graph rootVertices tmpVertices reversedSpaMap+ where reversedSpaMap = inToOutAdjMap chosenSpaMap+ chosenSpaMap = chooseSingleSPA iSpaMap+ tmpVertices = IntMap.foldrWithKey f [] iSpaMap+ f k l r = case l of+ [] -> if k `elem` rootVertices+ then r+ else k : r+ _ -> r+ iSpaMap = findSPA graph rootVertices+ (rootTiles, enumDeps) = flattenTransformResultWith id+ Q.FEVariable+ transformResult+ graph = graphFromFlatResult $ enumRootTiles ++ enumDeps+ -- Enumerated root tiles.+ enumRootTiles = zip [-1, -2 ..] rootTiles+ rootVertices = map fst enumRootTiles++-- | The lowest single parent ancestor state contains:+-- * A map of vertices mapping to their single parent ancestors.+--+type SState = IntMap.IntMap [G.Vertex]++-- | The state monad used to find single parent ancestors.+type SFinder = State SState++-- | Returns the list of single parent ancestors for a vertex or the empty list+-- if the vertex has not been processed yet.+sfGetSingleParentAncestors :: G.Vertex -> SFinder [G.Vertex]+sfGetSingleParentAncestors v = do+ result <- gets $ IntMap.lookup v++ return $ case result of+ -- Already calculated, return the spas and v itself.+ Just spas -> v : spas+ -- No entry yet. (Won't be called.)+ Nothing -> []++-- | Take a list of vertices and intersect their single parent ancestors with+-- each other, effectively calculating the single parent ancestors for this+-- vertex.+sfComputeSingleParentAncestors :: G.Vertex -> [G.Vertex] -> SFinder ()+sfComputeSingleParentAncestors v (pv:pvs) = do+ spa <- sfGetSingleParentAncestors pv+ spas <- mapM sfGetSingleParentAncestors pvs++ modify $ IntMap.insert v $ foldr L.intersect spa spas++sfComputeSingleParentAncestors v [] =+ -- v is a top level vertex.+ modify $ IntMap.insert v []++sfVertexProcessed :: G.Vertex -> SFinder Bool+sfVertexProcessed v = gets $ isJust . IntMap.lookup v++traverse :: Graph -- ^ The used graph.+ -> G.Vertex -- ^ The current vertex.+ -> SFinder ()+traverse graph v = do+ processedList <- mapM sfVertexProcessed parents++ -- Check whether all parents have been processed.+ when (and processedList) $ do+ sfComputeSingleParentAncestors v parents+ + -- Recurse over its children.+ mapM_ (traverse graph) $ G.children v graph++ where parents = G.parents v graph++-- | This function descends the given root vertices and returns the single+-- parent ancestors for each vertex, reachable by any of the given root+-- vertices.+-- A vertex with parents, which are not reachable through the given root nodes+-- can and will not be computed.+findSPA :: Graph+ -> [G.Vertex]+ -> IntMap.IntMap [G.Vertex]+findSPA graph rootVertices =+ -- Collect the results with the SFinder MonadState.+ execState (mapM_ (traverse graph) rootVertices) IntMap.empty+ +-- | Chooses the lowest single parent ancestor for each vertex.+chooseLowestSPA :: IntMap.IntMap [G.Vertex] -> IntMap.IntMap [G.Vertex]+chooseLowestSPA = fmap $ take 1++-- | Chooses the highest single parent ancestor for each vertex.+chooseHighestSPA :: IntMap.IntMap [G.Vertex] -> IntMap.IntMap [G.Vertex]+chooseHighestSPA = fmap f+ where f l = case l of+ [] -> []+ _ -> [last l]++-- | Reverses an out-adjacency map into an in-adjacency map.+inToOutAdjMap :: IntMap.IntMap [G.Vertex] -> IntMap.IntMap [G.Vertex]+inToOutAdjMap = IntMap.foldrWithKey f IntMap.empty+ where f key vertices rMap = foldr (g key) rMap vertices+ g key = IntMap.alter (h key)+ h v (Just x) = Just $ v : x+ h v Nothing = Just [v]++-- | Constructs a list of queries from the given arguments.+-- Takes an out-adjacency map of the single parent ancestors (which means the+-- child vertices are mapped from their corresponding single parent ancestor).+-- The map should resemble a tree structure (i.e. no vertex has multiple+-- parents), otherwise queries are executed multiple times.+queriesFromSPA :: Graph -- ^ Labeled graph.+ -> [G.Vertex] -- ^ Root vertices.+ -> [G.Vertex] -- ^ Temporary vertices.+ -> IntMap.IntMap [G.Vertex] -- ^ Out adjacency list.+ -> ([Q.Query], [Q.Query])+queriesFromSPA graph rootVertices tmpVertices reversedSpaMap =+ (tmpQueries, rootQueries)+ where tmpQueries = map tmpFun tmpVertices+ tmpFun v = Q.QDefinitionQuery . Q.DQTemporaryTable (build v)+ $ mat v+ rootQueries = map (Q.QValueQuery . build) rootVertices+ -- The materializer: t0, t1, t2, ...+ mat vertex = 't' : show vertex+ build = buildValueQuery graph reversedSpaMap mat++-- | Traverses the reversed SPA map like a tree, building a tree of CTEs,+-- starting at the given vertex.+buildValueQuery :: Graph -- ^ The corresponding graph.+ -> IntMap.IntMap [G.Vertex] -- ^ The reversed spa map.+ -> (G.Vertex -> String) -- ^ The materializer.+ -> G.Vertex -- ^ Vertex to build the query for.+ -> Q.ValueQuery+buildValueQuery graph reversedSpaMap mat v =+ if null bindings+ then body+ else Q.VQWith bindings body+ where childVertices = fromMaybe [] $ IntMap.lookup v reversedSpaMap+ childQueries = map (buildValueQuery graph reversedSpaMap mat)+ childVertices+ bindings = zip3 (map mat childVertices)+ (repeat Nothing)+ childQueries+ body = Q.VQSelect+ $ replaceReferencesSelectStmt (Q.FETableReference . mat)+ select+ select = fromMaybe (error "missing node label") $ G.node v graph+
+ src/Database/Algebra/SQL/Materialization/Graph.hs view
@@ -0,0 +1,56 @@+-- | Provides required graph tools.+module Database.Algebra.SQL.Materialization.Graph+ ( Graph+ , Vertex+ , mkGraph+ , parents+ , children+ , node+ , topSort+ , vertices+ , reachable+ ) where++import qualified Data.Graph.Inductive.Graph as G+import qualified Data.Graph.Inductive.PatriciaTree as P+import qualified Data.Graph.Inductive.Query.DFS as D++-- | The vertex type.+type Vertex = G.Node++-- | The graph type.+newtype Graph label = Graph+ { graph :: P.Gr label ()+ }++-- | Constructs a graph from the given out-adjacency list.+mkGraph :: [(label, Vertex, [Vertex])] -> Graph label+mkGraph outAdjacencyList = Graph $ G.mkGraph ns es+ where ns = map nf outAdjacencyList+ nf (n, k, _) = (k, n)+ ef (_, k, ks) = map (tf k) ks+ es = concatMap ef outAdjacencyList+ tf a b = (a, b, ())++-- | Fetches the parents of a vertex.+parents :: Vertex -> Graph label -> [Vertex]+parents v g = G.pre (graph g) v++-- | Fetches the children of a vertex.+children :: Vertex -> Graph label -> [Vertex]+children v g = G.suc (graph g) v++-- | Fetches the label of a vertex.+node :: Vertex -> Graph label -> Maybe label+node v g = G.lab (graph g) v++-- | Sorts the vertices topological.+topSort :: Graph label -> [Vertex]+topSort = D.topsort . graph++-- | Gets all vertices from a given graph.+vertices :: Graph label -> [Vertex]+vertices = G.nodes . graph++reachable :: Vertex -> Graph label -> [Vertex]+reachable v = D.reachable v . graph
+ src/Database/Algebra/SQL/Materialization/TemporaryTable.hs view
@@ -0,0 +1,24 @@+module Database.Algebra.SQL.Materialization.TemporaryTable+ ( materialize+ ) where++import Database.Algebra.SQL.Materialization+import Database.Algebra.SQL.Query+import Database.Algebra.SQL.Tile.Flatten++-- | Wrap all dependencies into temporary tables, and put the root tiles into+-- value queries.+materialize :: MatFun+materialize transformResult =+ ( map tmpTable deps+ , map (QValueQuery . VQSelect . fst) selects+ )+ where+ tmpTable (name, (body, _)) =+ QDefinitionQuery $ DQTemporaryTable (VQSelect body) name++ selects :: [FlatTile String]+ deps :: [(String, FlatTile String)]+ (selects, deps) =+ flattenTransformResult transformResult+
+ src/Database/Algebra/SQL/Materialization/Util.hs view
@@ -0,0 +1,23 @@++module Database.Algebra.SQL.Materialization.Util+ ( Graph+ , graphFromFlatResult+ ) where++import qualified Data.MultiSet as MS++import Database.Algebra.SQL.Tile.Flatten+import qualified Database.Algebra.SQL.Query as Q+import qualified Database.Algebra.SQL.Materialization.Graph as G++-- | The used graph.+type Graph = G.Graph Q.SelectStmt++-- | Generate a graph from tiles.+graphFromFlatResult :: [(Int, FlatTile Int)]+ -> Graph+graphFromFlatResult enumTiles =+ G.mkGraph $ map f enumTiles+ where f (identifier, (t, ds)) = (t, identifier, MS.toList ds)++
+ src/Database/Algebra/SQL/Query.hs view
@@ -0,0 +1,333 @@+module Database.Algebra.SQL.Query where++-- TODO Do we have to check for validity of types?+-- TODO is window clause standard?++-- | Mixed datatype for sequences of both types of queries.+data Query = QValueQuery+ { valueQuery :: ValueQuery+ }+ | QDefinitionQuery+ { definitionQuery :: DefinitionQuery+ } deriving Show++-- | A query which defines something (DDL).+data DefinitionQuery = -- CREATE MATERIALIZED VIEW foo AS ...+ DQMatView+ { sourceQuery :: ValueQuery+ , viewName :: String+ }+ -- A temporary table which is only existent in the current+ -- session.+ | DQTemporaryTable+ { sourceQuery :: ValueQuery+ , tTableName :: String+ } deriving Show++-- | A Query which has a table as a result.+data ValueQuery = VQSelect+ -- The contained select statement.+ { selectStmt :: SelectStmt+ }+ -- Literal tables (e.g. "VALUES (1, 2), (2, 4)").+ | VQLiteral+ { rows :: [[ColumnExpr]] -- ^ The values contained.+ }+ -- The with query to bind value queries to names.+ | VQWith+ { -- | The bindings of the with query as a list of tuples, each+ -- containing the table alias, the optional column names and+ -- the used query.+ cBindings :: [(String, Maybe [String], ValueQuery)]+ , cBody :: ValueQuery+ }+ -- A binary set operation+ -- (e.g. "TABLE foo UNION ALL TABLE bar").+ | VQBinarySetOperation+ { leftQuery :: ValueQuery -- ^ The left query.+ , rightQuery :: ValueQuery -- ^ The right query.+ -- The used (multi-) set operation.+ , operation :: SetOperation+ } deriving Show++-- | A (multi-) set operation for two sets.+data SetOperation = -- The union of two sets.+ SOUnionAll+ -- The difference of two sets.+ | SOExceptAll+ deriving Show++-- | Represents a SQL query using select and other optional clauses. The+-- reason this type is seperated (and not within VQSelect) is the use within+-- tile merging in earlier steps.+data SelectStmt = SelectStmt -- TODO do we need a window clause ?+ { -- | The constituents of the select clause.+ selectClause :: [SelectColumn] -- TODO should not be empty+ , -- | Indicates whether duplicates are removed.+ distinct :: Bool+ , -- | The constituents of the from clause.+ fromClause :: [FromPart] + , -- | A list of conjunctive column expression.+ whereClause :: [ColumnExpr]+ , -- | The values to group by.+ groupByClause :: [ColumnExpr]+ , -- | The values and direction to order the table after.+ orderByClause :: [OrderExpr]+ } deriving Show++-- | Tells which column to sort by and in which direction.+data OrderExpr = OE+ { -- | The expression to order after.+ oExpr :: ExtendedExpr+ , sortDirection :: SortDirection+ } deriving Show++-- | The direction to sort in.+data SortDirection = Ascending+ | Descending+ deriving Show++-- | Represents a subset of possible statements which can occur in a from+-- clause.+data FromPart = -- Used as "... FROM foo AS bar ...", but also as+ -- "... FROM foo ...", where the table reference is the alias.+ FPAlias+ { fExpr :: FromExpr -- ^ The aliased expression.+ , fName :: String -- ^ The name of the alias.+ , optColumns :: Maybe [String] -- ^ Optional column names.+ } deriving Show++-- A reference type used for placeholders.+type ReferenceType = Int++data FromExpr = -- Contains a subquery (e.g. "SELECT * FROM (TABLE foo) f;"),+ -- where "TABLE foo" is the sub query.+ FESubQuery+ { subQuery :: ValueQuery -- ^ The sub query.+ }+ | -- A placeholder which is substituted later.+ FEVariable+ { vIdentifier :: ReferenceType+ }+ -- Reference to an existing table.+ | FETableReference+ { tableReferenceName :: String -- ^ The name of the table.+ } deriving Show++ ++-- | Represents a subset of possible statements which can occur in a+-- select clause.+data SelectColumn = -- | @SELECT foo AS bar ...@+ SCAlias+ { sExpr :: ExtendedExpr -- ^ The value expression aliased.+ , sName :: String -- ^ The name of the alias.+ }+ | SCExpr ExtendedExpr+ deriving Show++-- | Basic value expressions extended by aggregates and window functions.+data ExtendedExpr =+ -- | Encapsulates the base cases.+ EEBase+ { valueExpr :: ValueExprTemplate ExtendedExpr -- ^ The value expression.+ }+ -- | @f() OVER (PARTITION BY p ORDER BY s framespec)@+ | EEWinFun+ { -- | Function to be computed over the window+ winFun :: WindowFunction+ -- | The expressions to partition by+ , partCols :: [AggrExpr]+ -- | Optional partition ordering+ , orderBy :: [WindowOrderExpr]+ -- | Optional frame specification+ , frameSpec :: Maybe FrameSpec+ }+ -- | Aggregate function expression. + | EEAggrExpr+ { aggrExpr :: AggrExpr+ } deriving Show++-- | Shorthand for the value expression base part of 'ExtendedExpr'.+type ExtendedExprBase = ValueExprTemplate ExtendedExpr++-- | A special order expression, which is used in windows of window functions.+-- This is needed because we can use window functions in the ORDER BY clause,+-- but not in window functions.+data WindowOrderExpr = WOE+ { woExpr :: AggrExpr+ , wSortDirection :: SortDirection+ } deriving Show++data FrameSpec = FHalfOpen FrameStart+ | FClosed FrameStart FrameEnd+ deriving (Show)++-- | Window frame start specification+data FrameStart = FSUnboundPrec -- ^ UNBOUNDED PRECEDING+ | FSValPrec Int -- ^ <value> PRECEDING+ | FSCurrRow -- ^ CURRENT ROW+ deriving (Show)++-- | Window frame end specification+data FrameEnd = FECurrRow -- ^ CURRENT ROW+ | FEValFol Int -- ^ <value> FOLLOWING+ | FEUnboundFol -- ^ UNBOUNDED FOLLOWING+ deriving (Show)++-- | Window functions+data WindowFunction = WFMax ColumnExpr+ | WFMin ColumnExpr+ | WFSum ColumnExpr+ | WFAvg ColumnExpr+ | WFAll ColumnExpr+ | WFAny ColumnExpr+ | WFFirstValue ColumnExpr+ | WFLastValue ColumnExpr+ | WFCount+ | WFRank+ | WFDenseRank+ | WFRowNumber+ deriving (Show)++-- | Basic value expressions extended only by aggregates.+data AggrExpr = AEBase (ValueExprTemplate AggrExpr)+ | AEAggregate+ { optValueExpr :: Maybe ColumnExpr+ , aFunction :: AggregateFunction+ } deriving Show++-- | Shorthand for the value expression base part of 'AggrExpr'.+type AggrExprBase = ValueExprTemplate AggrExpr+++-- | Aggregate functions.+data AggregateFunction = AFAvg+ | AFMax+ | AFMin+ | AFSum+ | AFCount+ | AFAll+ | AFAny+ deriving Show++-- | A template which allows the definition of a mutual recursive type for value+-- expressions, such that it can be extended with further constructors by other+-- data definitions.+data ValueExprTemplate rec =+ -- | Encapsulates a representation of a SQL value.+ VEValue+ { value :: Value -- ^ The value contained.+ }+ -- | A column.+ | VEColumn+ { cName :: String -- ^ The name of the column.+ -- | The optional prefix of the column.+ , cPrefix :: Maybe String+ }+ -- | A type cast (e.g. @CAST(1 AS DOUBLE PRECISION)@).+ | VECast+ { target :: rec -- ^ The target of the cast.+ , type_ :: DataType -- ^ The type to cast into.+ }+ -- | Application of a binary function.+ | VEBinApp+ { binFun :: BinaryFunction -- ^ The applied function.+ , firstExpr :: rec -- ^ The first operand.+ , secondExpr :: rec -- ^ The second operand.+ }+ | VEUnApp+ { unFun :: UnaryFunction -- ^ The applied function+ , arg :: rec -- ^ The operand+ }+ -- | Application of the not function.+ | VENot+ { nTarget :: rec -- ^ The expression to negate.+ }+ -- | e.g. @EXISTS (VALUES (1))@+ | VEExists+ { existsQuery :: ValueQuery -- ^ The query to check on.+ }+ -- | e.g. @1 IN (VALUES (1))@+ | VEIn+ { inExpr :: rec -- ^ The value to check for.+ , inQuery :: ValueQuery -- ^ The query to check in.+ }+ -- | CASE WHEN ELSE (restricted to one WHEN branch)+ | VECase+ { condExpr :: rec+ , thenBranch :: rec+ , elseBranch :: rec+ } deriving Show+-- FIXME merge VECast and VENot into UnaryFunction (maybe not possible)++-- | A type which does not extend basic value expressions, and therefore can+-- appear in any SQL clause.+newtype ColumnExpr = CEBase (ValueExprTemplate ColumnExpr)+ deriving Show++-- | Shorthand for the value expression base part of 'ColumnExpr'.+type ColumnExprBase = (ValueExprTemplate ColumnExpr)++-- | Types of binary functions.+data BinaryFunction = BFPlus+ | BFMinus+ | BFTimes+ | BFDiv+ | BFModulo+ | BFContains+ | BFSimilarTo+ | BFLike+ | BFConcat+ | BFGreaterThan+ | BFGreaterEqual+ | BFLowerThan+ | BFLowerEqual+ | BFEqual+ | BFNotEqual+ | BFAnd+ | BFOr+ deriving Show++-- | Types of unary functions+data UnaryFunction = UFSin+ | UFCos+ | UFTan+ | UFASin+ | UFACos+ | UFATan+ | UFSqrt+ | UFExp+ | UFLog+ | UFSubString Integer Integer+ deriving (Show)++-- | Types of valid SQL 99 datatypes (most likely a small subset) as stated in+-- 'SQL 1999: Understanding Relational Language Components' (Melton, Simon)+data DataType = -- | @INTEGER@+ DTInteger+ -- | @DECIMAL@+ | DTDecimal+ -- | @DOUBLE PRECISION@+ | DTDoublePrecision+ | DTText+ -- | @BOOLEAN@+ | DTBoolean+ deriving Show++data Value = -- | @42@+ VInteger Integer+ -- | Numeric data type with fixed precision and scale (e.g. @1.4@) + | VDecimal Float+ -- | A double precision floating point number. + | VDoublePrecision Double+ -- | e.g. @'foo'@+ | VText String+ -- | e.g. @TRUE@, @FALSE@ (but not UNKOWN in this variant)+ | VBoolean Bool+ -- | Representation of a null value. (While this can basically be+ -- part of any nullable type, it is added here for simplicity.+ -- Values aren't linked to types anyways.)+ | VNull+ deriving Show+
+ src/Database/Algebra/SQL/Query/Substitution.hs view
@@ -0,0 +1,179 @@+-- This module provides functions to replace references within queries.+module Database.Algebra.SQL.Query.Substitution+ ( replaceReferencesSelectStmt+ ) where++import Control.Monad (liftM)++import qualified Database.Algebra.SQL.Query as Q++type SubstitutionFunction = Q.ReferenceType -> Q.FromExpr++-- | Replaces all references in this 'Q.SelectStmt' with the result from the+-- given function.+replaceReferencesSelectStmt :: SubstitutionFunction+ -> Q.SelectStmt+ -> Q.SelectStmt+replaceReferencesSelectStmt r body =+ body+ { Q.selectClause = map (replaceReferencesSelectColumn r)+ $ Q.selectClause body+ , Q.fromClause = map (replaceReferencesFromPart r) $ Q.fromClause body+ , Q.whereClause = liftM (replaceReferencesColumnExpr r) $ Q.whereClause body+ , Q.groupByClause = map (replaceReferencesColumnExpr r)+ $ Q.groupByClause body+ , Q.orderByClause = map (replaceReferencesOrderExpr r)+ $ Q.orderByClause body+ }++replaceReferencesSelectColumn :: SubstitutionFunction+ -> Q.SelectColumn+ -> Q.SelectColumn+replaceReferencesSelectColumn r (Q.SCAlias e a) =+ Q.SCAlias (replaceReferencesExtendedExpr r e) a++replaceReferencesSelectColumn r (Q.SCExpr e) =+ Q.SCExpr $ replaceReferencesExtendedExpr r e++replaceReferencesExtendedExpr :: SubstitutionFunction+ -> Q.ExtendedExpr+ -> Q.ExtendedExpr+replaceReferencesExtendedExpr r (Q.EEBase v) =+ Q.EEBase $ replaceReferencesValueExprTemplate replaceReferencesExtendedExpr+ r+ v++replaceReferencesExtendedExpr r (Q.EEWinFun fun part ord frame) =+ Q.EEWinFun (replaceReferencesWindowFunction r fun)+ (liftM (replaceReferencesAggrExpr r) part)+ (map (replaceReferencesWindowOrderExpr r) ord)+ frame+replaceReferencesExtendedExpr r (Q.EEAggrExpr ae) =+ Q.EEAggrExpr $ replaceReferencesAggrExpr r ae++-- | Generic value expression substitution function.+replaceReferencesValueExprTemplate :: (SubstitutionFunction -> a -> a)+ -> SubstitutionFunction+ -> Q.ValueExprTemplate a+ -> Q.ValueExprTemplate a+replaceReferencesValueExprTemplate replaceReferencesRec r ve = case ve of+ Q.VECast tE t -> Q.VECast (replaceReferencesRec r tE) t+ Q.VEBinApp bf fe se ->+ Q.VEBinApp bf+ (replaceReferencesRec r fe)+ (replaceReferencesRec r se)+ Q.VEUnApp uf e -> Q.VEUnApp uf (replaceReferencesRec r e)+ Q.VENot e -> Q.VENot (replaceReferencesRec r e)+ Q.VECase cE tE eE -> Q.VECase (replaceReferencesRec r cE)+ (replaceReferencesRec r tE)+ (replaceReferencesRec r eE)+ Q.VEExists q -> Q.VEExists $ replaceReferencesValueQuery r q+ Q.VEIn ae q -> Q.VEIn (replaceReferencesRec r ae)+ (replaceReferencesValueQuery r q)+ Q.VEColumn _ _ -> ve+ Q.VEValue _ -> ve++replaceReferencesColumnExpr :: SubstitutionFunction+ -> Q.ColumnExpr+ -> Q.ColumnExpr+replaceReferencesColumnExpr r (Q.CEBase v) =+ Q.CEBase $ replaceReferencesValueExprTemplate replaceReferencesColumnExpr+ r+ v++replaceReferencesAggrExpr :: SubstitutionFunction+ -> Q.AggrExpr+ -> Q.AggrExpr+replaceReferencesAggrExpr r (Q.AEBase v) =+ Q.AEBase $ replaceReferencesValueExprTemplate replaceReferencesAggrExpr+ r+ v+replaceReferencesAggrExpr r (Q.AEAggregate v f) =+ Q.AEAggregate (liftM (replaceReferencesColumnExpr r) v) f++replaceReferencesFromPart :: SubstitutionFunction+ -> Q.FromPart+ -> Q.FromPart+replaceReferencesFromPart r (Q.FPAlias e a c) =+ Q.FPAlias (replaceReferencesFromExpr r e) a c++replaceReferencesFromExpr :: SubstitutionFunction+ -> Q.FromExpr+ -> Q.FromExpr+replaceReferencesFromExpr r (Q.FESubQuery q) =+ Q.FESubQuery $ replaceReferencesValueQuery r q++replaceReferencesFromExpr r (Q.FEVariable v) = r v++replaceReferencesFromExpr _ t = t++replaceReferencesValueQuery :: SubstitutionFunction+ -> Q.ValueQuery+ -> Q.ValueQuery+replaceReferencesValueQuery r (Q.VQSelect s) =+ Q.VQSelect $ replaceReferencesSelectStmt r s++replaceReferencesValueQuery r+ (Q.VQWith bindings body) =+ Q.VQWith (map f bindings) $ replaceReferencesValueQuery r body+ where f (n, oC, q) = (n, oC, replaceReferencesValueQuery r q)++replaceReferencesValueQuery r+ (Q.VQBinarySetOperation lq rq o) =+ Q.VQBinarySetOperation (replaceReferencesValueQuery r lq)+ (replaceReferencesValueQuery r rq)+ o++replaceReferencesValueQuery _ q = q++replaceReferencesOrderExpr :: SubstitutionFunction+ -> Q.OrderExpr+ -> Q.OrderExpr+replaceReferencesOrderExpr r (Q.OE ee d) =+ Q.OE (replaceReferencesExtendedExpr r ee) d++replaceReferencesWindowOrderExpr :: SubstitutionFunction+ -> Q.WindowOrderExpr+ -> Q.WindowOrderExpr+replaceReferencesWindowOrderExpr r (Q.WOE ae d) =+ Q.WOE (replaceReferencesAggrExpr r ae) d+++replaceReferencesWindowFunction :: SubstitutionFunction+ -> Q.WindowFunction+ -> Q.WindowFunction+replaceReferencesWindowFunction r (Q.WFMax a) = + Q.WFMax (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFMin a) = + Q.WFMin (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFSum a) = + Q.WFSum (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFAvg a) = + Q.WFAvg (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFAll a) = + Q.WFAll (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFAny a) = + Q.WFAny (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFFirstValue a) = + Q.WFFirstValue (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction r (Q.WFLastValue a) = + Q.WFLastValue (replaceReferencesColumnExpr r a)++replaceReferencesWindowFunction _ Q.WFCount = + Q.WFCount++replaceReferencesWindowFunction _ Q.WFRank = + Q.WFRank++replaceReferencesWindowFunction _ Q.WFDenseRank = + Q.WFDenseRank++replaceReferencesWindowFunction _ Q.WFRowNumber = + Q.WFRowNumber
+ src/Database/Algebra/SQL/Query/Util.hs view
@@ -0,0 +1,80 @@+-- | This module exports useful functions for working with the 'Query' ADT.+module Database.Algebra.SQL.Query.Util+ ( emptySelectStmt+ , mkPCol+ , mkSubQuery+ , affectsSortOrderCE+ , affectsSortOrderAE+ , affectsSortOrderEE+ ) where++import Database.Algebra.SQL.Query as Q++-- | Helper value to construct select statements.+emptySelectStmt :: Q.SelectStmt+emptySelectStmt = Q.SelectStmt [] False [] [] [] []++-- | Shorthand to make a prefixed column value expression.+mkPCol :: String+ -> String+ -> Q.ValueExprTemplate a+mkPCol p c = Q.VEColumn c $ Just p++-- | Embeds a query into a from part as sub query.+mkSubQuery :: Q.SelectStmt+ -> String+ -> Maybe [String]+ -> Q.FromPart+mkSubQuery sel = Q.FPAlias (Q.FESubQuery $ Q.VQSelect sel)++-- | Check whether we need an expression within an ORDER BY / GROUP BY /+-- PARTITION BY clause, based on a simple heuristic. The main purpose is to+-- eliminate single values, everything else is optional. This means that some+-- expressions have no effect on the sort order but will still return 'True'.+affectsSortOrderValueExprTemplate :: (a -> Bool)+ -> Q.ValueExprTemplate a+ -> Bool+affectsSortOrderValueExprTemplate affectsSortOrderRec ve = case ve of+ -- A constant value won't affect the sort order.+ Q.VEValue _ -> False+ Q.VEColumn _ _ -> True+ Q.VECast e1 _ -> affectsSortOrderRec e1+ Q.VEBinApp _ e1 e2 -> affectsSortOrderRec e1 || affectsSortOrderRec e2+ Q.VEUnApp _ e1 -> affectsSortOrderRec e1+ Q.VENot e1 -> affectsSortOrderRec e1+ -- We have no correlated queries (in open tiles), but in case we get some,+ -- this is the most flexible solution.+ Q.VEExists _ -> True+ Q.VEIn _ _ -> True+ Q.VECase c t e ->+ affectsSortOrderRec c || affectsSortOrderRec t || affectsSortOrderRec e++affectsSortOrderCE :: Q.ColumnExpr -> Bool+affectsSortOrderCE (Q.CEBase e) =+ affectsSortOrderValueExprTemplate affectsSortOrderCE e++affectsSortOrderEE :: Q.ExtendedExpr -> Bool+affectsSortOrderEE e = case e of+ EEBase ve -> affectsSortOrderValueExprTemplate affectsSortOrderEE ve+ EEWinFun{} -> True+ EEAggrExpr ae -> affectsSortOrderAE ae++affectsSortOrderAE :: Q.AggrExpr -> Bool+affectsSortOrderAE ae = case ae of+ AEBase ve -> affectsSortOrderValueExprTemplate affectsSortOrderAE ve+ -- TODO+ AEAggregate _ _ -> True++--isMergeable :: Q.SelectStmt -> Bool+--isMergeable (Q.SelectStmt sClause d _ _ [] _) =+-- not $ d || any (usesExtendedExprs . sExpr) sClause+-- where+-- usesExtendedExprs e = case e of+-- EEBase _ -> False+-- _ -> True+--isMergeable _ = False++-- | Search for references and try to merge a select stmt at that position.+--deepMergeSelectStmt :: (Int -> (Bool, Q.SelectStmt)) -> Q.SelectStmt -> Q.SelectStmt+--deepMergeSelectStmt lookupFun select =+
+ src/Database/Algebra/SQL/Render.hs view
@@ -0,0 +1,49 @@+-- | This mdoule provides efficient functions to render lists of queries.+module Database.Algebra.SQL.Render+ ( debugTransformResult+ , renderCompact+ , renderPretty+ , renderPlain+ ) where++import qualified Text.PrettyPrint.ANSI.Leijen as L+ ( Doc+ , SimpleDoc+ , plain+ , displayS+ , renderPretty+ , renderCompact+ )++import Database.Algebra.SQL.Query (Query)+import Database.Algebra.SQL.Render.Query (renderQuery)+import Database.Algebra.SQL.Render.Tile (renderTransformResult)+import Database.Algebra.SQL.Tile (TransformResult)+import Database.Algebra.SQL.Compatibility++renderPrettySimpleDoc :: L.Doc -> L.SimpleDoc+renderPrettySimpleDoc =+ L.renderPretty 0.8 80++renderWith :: (L.Doc -> L.SimpleDoc) -> CompatMode -> Query -> ShowS+renderWith f c = L.displayS . f . renderQuery c+++-- | Returns a 'ShowS' containing debug information for a transform result.+debugTransformResult :: CompatMode -> TransformResult -> ShowS+debugTransformResult compat =+ L.displayS . renderPrettySimpleDoc . (renderTransformResult compat)++-- | Renders a list of queries in an ugly but fast way, feasible as direct SQL+-- input.+renderCompact :: CompatMode -> [Query] -> [ShowS]+renderCompact c = map $ renderWith L.renderCompact c++-- | Renders a list of queries in a beautiful way.+renderPretty :: CompatMode -> [Query] -> [ShowS]+renderPretty c = map $ renderWith renderPrettySimpleDoc c++-- | Renders a list of queries without colors but formatted.+renderPlain :: CompatMode -> [Query] -> [ShowS]+renderPlain c = map $ renderWith (renderPrettySimpleDoc . L.plain) c+
+ src/Database/Algebra/SQL/Render/Query.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE TemplateHaskell #-}++-- This file determines the semantics of the 'Query' data structure and all of+-- its sub structures.+module Database.Algebra.SQL.Render.Query+ ( renderQuery+ , renderSelectStmt+ ) where++import Text.PrettyPrint.ANSI.Leijen ( (<$>)+ , (<+>)+ , (</>)+ , (<>)+ , Doc+ , align+ , bold+ , char+ , comma+ , double+ , empty+ , fillSep+ , float+ , hang+ , hsep+ , indent+ , int+ , integer+ , linebreak+ , lparen+ , ondullblue+ , parens+ , punctuate+ , red+ , rparen+ , sep+ , squotes+ , text+ , vcat+ )++import Database.Algebra.Impossible+import Database.Algebra.SQL.Query+import Database.Algebra.SQL.Compatibility++enlist :: [Doc] -> Doc+enlist = fillSep . punctuate comma++-- Does the same as enlist but does not break the line.+enlistOnLine :: [Doc] -> Doc+enlistOnLine = hsep . punctuate comma++-- | A keyword.+kw :: String -> Doc+kw = red . text++-- | A single character keyword.+op :: Char -> Doc+op = red . char++-- | Terminate a SQL query.+terminate :: Doc -> Doc+terminate = (<> op ';')++renderQuery :: CompatMode -> Query -> Doc+renderQuery c query = terminate $ case query of+ QValueQuery q -> renderValueQuery c q+ QDefinitionQuery q -> renderDefinitionQuery c q++renderDefinitionQuery :: CompatMode -> DefinitionQuery -> Doc+renderDefinitionQuery compat (DQMatView query name) =+ kw "CREATE MATERIALIZED VIEW"+ <+> text name+ <+> kw "AS"+ </> renderValueQuery compat query++renderDefinitionQuery compat (DQTemporaryTable query name) =+ createStmt+ <+>+ case compat of+ PostgreSQL ->+ -- PostgreSQL does not accept the default syntax. In order to+ -- achieve the same behaviour, the SQL code is rendered differently.+ kw "ON COMMIT DROP"+ <+> as+ <$> indentedQuery++ -- Default implementation for SQL:1999 compliant DBMS. + _ ->+ as+ <$> indentedQuery+ -- Create the table with the result of the given value query.+ <$> kw "WITH DATA ON COMMIT DROP"+ where+ createStmt = kw "CREATE LOCAL TEMPORARY TABLE" <+> text name+ as = kw "AS"+ indentedQuery = indent 4 $ renderValueQuery compat query++renderValueQuery :: CompatMode -> ValueQuery -> Doc+renderValueQuery compat (VQSelect stmt) = renderSelectStmt compat stmt+renderValueQuery compat (VQLiteral vals) =+ kw "VALUES" <+> align (sep . punctuate comma $ map renderRow vals)+ where renderRow row = parens . enlistOnLine $ map (renderColumnExpr compat) row++renderValueQuery compat (VQWith bindings body) =+ hang 4 (kw "WITH" </> enlist (map renderBinding bindings))+ <$> renderValueQuery compat body+ where renderBinding :: (String, Maybe [String], ValueQuery) -> Doc+ renderBinding (name, optCols, query) =+ text name+ <> renderOptColDefs optCols+ <+> kw "AS"+ <+> lparen+ <$> indent 4 (renderValueQuery compat query)+ <$> rparen++renderValueQuery compat (VQBinarySetOperation left right o) =+ renderValueQuery compat left+ <> linebreak+ <$> renderSetOperation o+ <> linebreak+ <$> renderValueQuery compat right++renderSetOperation :: SetOperation -> Doc+renderSetOperation SOUnionAll = kw "UNION ALL"+renderSetOperation SOExceptAll = kw "EXCEPT ALL"++-- | Render a conjunction list, renders the neutral element, when given the+-- empty list.+renderAndList :: CompatMode -> [ColumnExpr] -> Doc+renderAndList compat l = case l of+ [] -> kw "TRUE"+ _ -> align $ hsep $ punctuate (linebreak <> kw "AND")+ $ map (renderColumnExpr compat) l++renderSelectStmt :: CompatMode -> SelectStmt -> Doc+renderSelectStmt compat stmt =+ kw "SELECT"+ <+> align ( let sC = enlist $ map (renderSelectColumn compat) $ selectClause stmt+ in if distinct stmt+ then kw "DISTINCT" <+> sC+ else sC+ )+ + <> case fromClause stmt of+ [] -> empty+ fromParts ->+ linebreak+ <> kw "FROM"+ <+> align ( vcat . punctuate comma+ $ map (renderFromPart compat) fromParts+ )+ <> case whereClause stmt of+ [] -> empty+ l -> linebreak+ <> kw "WHERE"+ <+> renderAndList compat l+ <> case groupByClause stmt of+ [] -> empty+ valExpr -> linebreak+ <> kw "GROUP BY"+ <+> align (enlist $ map (renderColumnExpr compat) valExpr)+ <> case orderByClause stmt of+ [] -> empty+ order -> linebreak+ <> kw "ORDER BY"+ <+> align ( renderGenericOrderByList renderOrderExpr+ compat+ order+ ) +++renderOrderExpr :: CompatMode -> OrderExpr -> Doc+renderOrderExpr compat (OE ee dir) =+ renderExtendedExpr compat ee+ <+> renderSortDirection dir++renderWindowOrderExpr :: CompatMode -> WindowOrderExpr -> Doc+renderWindowOrderExpr compat (WOE ae dir) =+ renderAggrExpr compat ae+ <+> renderSortDirection dir++-- | Render a list of generic order expressions.+renderGenericOrderByList :: (CompatMode -> o -> Doc) -> CompatMode -> [o] -> Doc+renderGenericOrderByList renderGenericOrderExpr compat =+ enlistOnLine . map (renderGenericOrderExpr compat)++renderWindowOrderByList :: CompatMode -> [WindowOrderExpr] -> Doc+renderWindowOrderByList compat wos =+ kw "ORDER BY" <+> renderGenericOrderByList renderWindowOrderExpr compat wos++renderFrameSpec :: FrameSpec -> Doc+renderFrameSpec (FHalfOpen fs) = kw "ROWS" <+> renderFrameStart fs+renderFrameSpec (FClosed fs fe) = kw "ROWS BETWEEN"+ <+> renderFrameStart fs + <+> kw "AND" + <+> renderFrameEnd fe++renderFrameStart :: FrameStart -> Doc+renderFrameStart FSUnboundPrec = text "UNBOUNDED PRECEDING"+renderFrameStart (FSValPrec i) = int i <+> text "PRECEDING"+renderFrameStart FSCurrRow = text "CURRENT ROW"++renderFrameEnd :: FrameEnd -> Doc+renderFrameEnd FEUnboundFol = text "UNBOUNDED FOLLOWING"+renderFrameEnd (FEValFol i) = int i <+> text "FOLLOWING"+renderFrameEnd FECurrRow = text "CURRENT ROW"++renderSortDirection :: SortDirection -> Doc+renderSortDirection Ascending = kw "ASC"+renderSortDirection Descending = kw "DESC"++-- | Render a list of columns as definition within a from clause or within+-- a common table expression.+renderOptColDefs :: Maybe [String] -> Doc+renderOptColDefs = maybe empty colDoc+ where colDoc = parens . enlistOnLine . map text++renderFromPart :: CompatMode -> FromPart -> Doc+renderFromPart _ (FPAlias (FETableReference n) alias _) =+ -- Don't use positional mapping on table references, since they are mapped+ -- by their name.+ text n+ <+> kw "AS"+ <+> text alias++renderFromPart compat (FPAlias expr alias optCols) =+ renderFromExpr compat expr+ <+> kw "AS"+ <+> text alias+ <> renderOptColDefs optCols++renderSubQuery :: CompatMode -> ValueQuery -> Doc+renderSubQuery compat q = lparen <+> align (renderValueQuery compat q) <$> rparen++renderFromExpr :: CompatMode -> FromExpr -> Doc+renderFromExpr compat (FESubQuery q) = renderSubQuery compat q+renderFromExpr _ (FEVariable v) = ondullblue $ int v+renderFromExpr _ (FETableReference n) = text n++-- | Renders an optional prefix.+renderOptPrefix :: Maybe String -> Doc+renderOptPrefix = maybe empty $ (<> char '.') . text+++renderSelectColumn :: CompatMode -> SelectColumn -> Doc+renderSelectColumn compat (SCAlias expr name) = renderExtendedExpr compat expr+ <+> kw "AS"+ <+> text name+renderSelectColumn compat (SCExpr expr) = renderExtendedExpr compat expr+++renderExtendedExpr :: CompatMode -> ExtendedExpr -> Doc+renderExtendedExpr compat (EEBase v) = renderExtendedExprBase compat v+renderExtendedExpr compat (EEWinFun wfun partExprs order mFrameSpec) =+ renderWindowFunction compat wfun+ <+> kw "OVER"+ <+> parens (partitionByDoc <> orderByDoc <> frameSpecDoc) ++ where+ partitionByDoc = case partExprs of+ [] -> empty+ _ -> kw "PARTITION BY"+ </> enlist (map (renderAggrExpr compat) partExprs)+ <> linebreak++ orderByDoc = case order of+ [] -> empty+ _ -> renderWindowOrderByList compat order <> linebreak+ + frameSpecDoc = maybe empty (\fs -> renderFrameSpec fs) mFrameSpec++renderExtendedExpr compat (EEAggrExpr ae) =+ renderAggrExpr compat ae++renderAggrExpr :: CompatMode -> AggrExpr -> Doc+renderAggrExpr compat e = case e of+ AEBase ve ->+ renderValueExprTemplate renderAggrExpr compat ve++ AEAggregate optVE aggr -> + renderAggregateFunction compat aggr+ <> parens (maybe (char '*') (renderColumnExpr compat) optVE)++-- | Generic 'ValueExprTemplate' renderer.+renderValueExprTemplate :: (CompatMode -> a -> Doc)+ -> CompatMode+ -> ValueExprTemplate a+ -> Doc+renderValueExprTemplate renderRec compat ve = case ve of+ VEValue v -> renderValue v+ VEColumn n optPrefix -> renderOptPrefix optPrefix+ <> text n+ VECast v ty ->+ kw "CAST" <> parens castDoc+ where castDoc = renderRec compat v+ <+> kw "AS" <+> renderDataType ty++ VEBinApp f a b -> parens $ renderRec compat a+ <+> renderBinaryFunction f+ <+> renderRec compat b++ VEUnApp (UFSubString f t) a -> renderSubString renderRec compat f t a+ VEUnApp f a ->+ parens $ renderUnaryFunction f <> parens (renderRec compat a)++ VENot a -> parens $ kw "NOT" <+> renderRec compat a+ VEExists q -> kw "EXISTS" <+> renderSubQuery compat q++ VEIn v q -> parens $ renderRec compat v+ <+> kw "IN"+ <+> renderSubQuery compat q+ VECase c t e ->+ text "CASE WHEN" <+> renderRec compat c+ <+> text "THEN"+ <+> renderRec compat t+ <+> text "ELSE"+ <+> renderRec compat e+ <+> text "END"++renderSubString :: (CompatMode -> a -> Doc)+ -> CompatMode + -> Integer + -> Integer + -> a+ -> Doc+renderSubString renderRec compat from to argExpr =+ case compat of+ SQL99 -> kw "substring" <> parens (renderRec compat argExpr+ <+> text "from" <+> integer from+ <+> text "for" <+> integer to)+ PostgreSQL -> kw "substr" <> parens (hsep $ punctuate comma [ renderRec compat argExpr+ , integer from+ , integer to+ ])+ MonetDB -> kw "substring" <> parens (hsep $ punctuate comma [ renderRec compat argExpr+ , integer from+ , integer to+ ])++-- | Render a 'ExtendedExprBase' with the generic renderer.+renderExtendedExprBase :: CompatMode -> ExtendedExprBase -> Doc+renderExtendedExprBase = renderValueExprTemplate renderExtendedExpr+ ++-- | Render a 'ColumnExprBase' with the generic renderer.+renderColumnExprBase :: CompatMode -> ColumnExprBase -> Doc+renderColumnExprBase = renderValueExprTemplate renderColumnExpr++renderAggregateFunction :: CompatMode -> AggregateFunction -> Doc+renderAggregateFunction _ AFAvg = kw "AVG"+renderAggregateFunction _ AFMax = kw "MAX"+renderAggregateFunction _ AFMin = kw "MIN"+renderAggregateFunction _ AFSum = kw "SUM"+renderAggregateFunction _ AFCount = kw "COUNT"+renderAggregateFunction PostgreSQL AFAll = kw "BOOL_AND"+renderAggregateFunction SQL99 AFAll = kw "EVERY"+renderAggregateFunction MonetDB AFAll = kw "MIN"+renderAggregateFunction PostgreSQL AFAny = kw "BOOL_OR"+renderAggregateFunction SQL99 AFAny = kw "SOME"+renderAggregateFunction MonetDB AFAny = kw "MAX"++renderFunCall :: String -> Doc -> Doc+renderFunCall funName funArg = kw funName <> parens funArg++renderWindowFunction :: CompatMode -> WindowFunction -> Doc+renderWindowFunction _ WFRowNumber = renderFunCall "ROW_NUMBER" empty+renderWindowFunction _ WFDenseRank = renderFunCall "DENSE_RANK" empty+renderWindowFunction _ WFRank = renderFunCall "RANK" empty+renderWindowFunction MonetDB _ = error "MonetDB does not support window aggregates"+renderWindowFunction c (WFAvg a) = renderFunCall "AVG" (renderColumnExpr c a)+renderWindowFunction c (WFMax a) = renderFunCall "MAX" (renderColumnExpr c a)+renderWindowFunction c (WFMin a) = renderFunCall "MIN" (renderColumnExpr c a)+renderWindowFunction c (WFSum a) = renderFunCall "SUM" (renderColumnExpr c a)+renderWindowFunction c (WFFirstValue a) = renderFunCall "first_value" (renderColumnExpr c a)+renderWindowFunction c (WFLastValue a) = renderFunCall "last_value" (renderColumnExpr c a)+renderWindowFunction _ WFCount = renderFunCall "COUNT" (text "*")+renderWindowFunction PostgreSQL (WFAll a) = renderFunCall "bool_and" + (renderColumnExpr PostgreSQL a)+renderWindowFunction SQL99 (WFAll a) = renderFunCall "EVERY" + (renderColumnExpr SQL99 a)+renderWindowFunction PostgreSQL (WFAny a) = renderFunCall "bool_or" + (renderColumnExpr PostgreSQL a)+renderWindowFunction SQL99 (WFAny a) = renderFunCall "SOME" + (renderColumnExpr SQL99 a)++renderColumnExpr :: CompatMode -> ColumnExpr -> Doc+renderColumnExpr compat (CEBase e) = renderColumnExprBase compat e+++renderBinaryFunction :: BinaryFunction -> Doc+renderBinaryFunction BFPlus = op '+'+renderBinaryFunction BFMinus = op '-'+renderBinaryFunction BFTimes = op '*'+renderBinaryFunction BFDiv = op '/'+renderBinaryFunction BFModulo = op '%'+renderBinaryFunction BFContains = op '~'+renderBinaryFunction BFSimilarTo = kw "SIMILAR TO"+renderBinaryFunction BFLike = kw "LIKE"+renderBinaryFunction BFConcat = kw "||"+renderBinaryFunction BFGreaterThan = op '>'+renderBinaryFunction BFGreaterEqual = kw ">="+renderBinaryFunction BFLowerThan = op '<'+renderBinaryFunction BFLowerEqual = kw "<="+renderBinaryFunction BFEqual = op '='+renderBinaryFunction BFNotEqual = kw "<>"+renderBinaryFunction BFAnd = kw "AND"+renderBinaryFunction BFOr = kw "OR"++renderUnaryFunction :: UnaryFunction -> Doc+renderUnaryFunction UFSin = kw "sin"+renderUnaryFunction UFCos = kw "cos"+renderUnaryFunction UFTan = kw "tan"+renderUnaryFunction UFLog = kw "log"+renderUnaryFunction UFSqrt = kw "sqrt"+renderUnaryFunction UFExp = kw "exp"+renderUnaryFunction UFASin = kw "asin"+renderUnaryFunction UFACos = kw "acos"+renderUnaryFunction UFATan = kw "atan"+-- The substring combinator is rendered speciall+renderUnaryFunction UFSubString{} = $impossible++renderDataType :: DataType -> Doc+renderDataType DTInteger = kw "INTEGER"+renderDataType DTDecimal = kw "DECIMAL"+renderDataType DTDoublePrecision = kw "DOUBLE PRECISION"+renderDataType DTText = kw "TEXT"+renderDataType DTBoolean = kw "BOOLEAN" ++literal :: Doc -> Doc+literal = bold++renderValue :: Value -> Doc+renderValue v = case v of+ VInteger i -> literal $ integer i+ VDecimal d -> literal $ float d+ VDoublePrecision d -> literal $ double d+ VText str -> literal $ squotes $ text str+ VBoolean b -> kw $ if b then "TRUE" else "FALSE"+ VNull -> literal $ text "null"+
+ src/Database/Algebra/SQL/Render/Tile.hs view
@@ -0,0 +1,75 @@+module Database.Algebra.SQL.Render.Tile+ ( renderTransformResult+ ) where+++import Text.PrettyPrint.ANSI.Leijen ( (<$>)+ , (<+>)+ , (<>)+ , Doc+ , align + , black+ , bold+ , empty+ , indent+ , int+ , linebreak+ , ondullblue+ , onwhite+ , punctuate+ , text+ , vcat+ , vsep+ )+import qualified Data.DList as DL+ ( toList+ )++import qualified Database.Algebra.SQL.Render.Query as RQ+import qualified Database.Algebra.SQL.Query as Q+import Database.Algebra.SQL.Tile+import Database.Algebra.SQL.Compatibility++intRef :: InternalReference -> Doc+intRef = ondullblue . int++extRef :: ExternalReference -> Doc+extRef = onwhite . black . bold . int++type_ :: String -> Doc+type_ = bold . text++renderTileTreeNode :: CompatMode -> Q.SelectStmt -> [(Int, TileTree)] -> Doc+renderTileTreeNode compat body children =+ type_ "tile"+ <$> RQ.renderSelectStmt compat body+ <> if null children+ then empty+ else linebreak <> bold (text "children") <+> align (vsep rC)+ where rC = map f children+ f (vId, t) = intRef vId <+> align (renderTileTree compat t)+++renderTileTree :: CompatMode -> TileTree -> Doc+renderTileTree _ (ReferenceLeaf n _) = type_ "references"+ <+> extRef n+renderTileTree compat (TileNode features body children) =+ type_ ( show features+ )+ <+> renderTileTreeNode compat body children++renderTransformResult :: CompatMode -> ([TileTree], DependencyList) -> Doc+renderTransformResult compat (ts, dl) =+ type_ "queries"+ <$> indent 4 (vcat (punctuate linebreak (map (renderTileTree compat) ts)))+ <> if null depList+ then empty+ else ( linebreak+ <> type_ "dependencies"+ <$> indent 4 deps+ )+ where deps = vsep $ map f depList+ f (r, tree) = extRef r+ <+> bold (text "as")+ <+> align (renderTileTree compat tree)+ depList = DL.toList dl
+ src/Database/Algebra/SQL/Termination.hs view
@@ -0,0 +1,108 @@+-- | Datatypes and functions which determine termination of SQL fragements.+module Database.Algebra.SQL.Termination+ ( FeatureSet+ , terminatesOver+ , noneF+ , projectF+ , filterF+ , tableF+ , dupElimF+ , sortF+ , windowFunctionF+ , aggrAndGroupingF+ , module Data.Monoid+ ) where++import Data.List (intercalate)+import Data.Monoid+import qualified Data.Set as S++-- | Specifies a part in a SQL statement which is currently in use.+data Feature = ProjectionF -- ^ Projection of columns.+ | TableF -- ^ Physical or virtual table.+ | FilterF -- ^ Filtering of rows.+ | DupElimF+ | SortF+ | WindowFunctionF+ | AggrAndGroupingF+ deriving (Eq, Ord, Show)++-- TODO maybe use just list, since we usually have so few+newtype FeatureSet = F { unF :: S.Set Feature }++wrap :: Feature -> FeatureSet+wrap = F . S.singleton++noneF, projectF, filterF, tableF, dupElimF, sortF, windowFunctionF, aggrAndGroupingF :: FeatureSet+noneF = F S.empty+projectF = wrap ProjectionF+filterF = wrap FilterF+tableF = wrap TableF+dupElimF = wrap DupElimF+sortF = wrap SortF+windowFunctionF = wrap WindowFunctionF+aggrAndGroupingF = wrap AggrAndGroupingF++instance Monoid FeatureSet where+ mempty = noneF+ mappend (F l) (F r) = F $ l `S.union` r+ mconcat fs = F $ S.unions $ map unF fs++instance Show FeatureSet where+ show (F s) = "<" ++ intercalate ", " (map show $ S.toList s) ++ ">"+++-- | Lists all features which lead to a termination, for a given feature+-- coming from an operator placed below.+terminatingFeatures :: Feature -> FeatureSet+terminatingFeatures bottomF = F $ case bottomF of+ ProjectionF -> S.empty+ TableF -> S.empty+ FilterF -> S.empty+ -- Distinction has to occur before:+ --+ -- * Projection of columns: Because there exist cases where to much gets+ -- removed.+ --+ -- * Aggregation: Because the previous result set influences the value+ -- of aggregate functions, including duplicates.+ --+ -- * Grouping: Grouping could project away columns, which are needed for+ -- duplicate elimination.+ --+ DupElimF -> S.fromList [ProjectionF, AggrAndGroupingF]+ -- The ORDER BY clause will only be used on top.+ SortF -> S.empty+ -- Problematic cases:+ --+ -- * Filtering: May change the intermediate result set.+ --+ -- * Duplicate removal with DISTINCT has another semantic meaning.+ --+ -- * Stacked window functions can possibly have other windows and window+ -- functions can not be nested.+ --+ -- * Aggregates of window functions can not be built.+ --+ WindowFunctionF ->+ S.fromList [FilterF, DupElimF, WindowFunctionF, AggrAndGroupingF]+ -- Problematic cases:+ -- + -- * Filtering: May change intermediate result set.+ --+ -- * Aggregate functions can not be stacked.+ --+ -- * Is there a case, where OLAP functions using windows with aggregates+ -- makes sense? It is possible, and inlining works, therefore it is+ -- enabled.+ --+ AggrAndGroupingF -> S.fromList [FilterF, AggrAndGroupingF]++-- | Determines whether two feature sets collide and therefore whether we should+-- terminate a SQL fragment.+terminatesOver :: FeatureSet -> FeatureSet -> Bool+terminatesOver (F topFs) (F bottomFs) =+ any (`S.member` conflictingFs) $ S.toList topFs+ where+ (F conflictingFs) = mconcat $ map terminatingFeatures $ S.toList bottomFs+
+ src/Database/Algebra/SQL/Tile.hs view
@@ -0,0 +1,1028 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.Algebra.SQL.Tile+ ( TileTree (TileNode, ReferenceLeaf)+ , TileChildren+ , ExternalReference+ , InternalReference+ , DependencyList+ , TransformResult+ , transform+ , TADag+ ) where++-- TODO maybe split this file into the tile definition+-- and the transform things.+-- TODO embed closing tiles as subqueries (are there any sub queries which are+-- correlated?)? (reader?)+-- TODO isMultiReferenced special case: check for same parent !!++import Control.Arrow (second)+import Control.Monad.RWS.Strict+import qualified Data.DList as DL (DList, singleton)+import qualified Data.IntMap as IntMap+import Data.Maybe+import GHC.Exts hiding (inline)++import qualified Database.Algebra.Dag as D+import qualified Database.Algebra.Dag.Common as C+import Database.Algebra.Impossible+import qualified Database.Algebra.Table.Lang as A++import qualified Database.Algebra.SQL.Query as Q+import Database.Algebra.SQL.Termination+import Database.Algebra.SQL.Query.Util++-- | A tile internal reference type.+type InternalReference = Q.ReferenceType++-- | The type used to reference table expressions outside of a tile.+type ExternalReference = Int++-- | Aliased tile children, where the first part is the alias used within the+-- 'Q.SelectStmt'.+type TileChildren = [(InternalReference, TileTree)]++-- | Defines the tile tree structure.+data TileTree = -- | A tile: The first argument determines which features the+ -- 'Q.SelectStmt' uses.+ TileNode FeatureSet Q.SelectStmt TileChildren+ -- | A reference pointing to another TileTree: The second+ -- argument specifies the columns of the referenced table+ -- expression.+ | ReferenceLeaf ExternalReference [String]++-- | Table algebra DAGs+type TADag = D.AlgebraDag A.TableAlgebra++-- | Association list (where dependencies should be ordered topologically).+type DependencyList = DL.DList (ExternalReference, TileTree)+++-- | A combination of types which need to be modified state wise while+-- transforming:+-- * The processed nodes with multiple parents.+--+-- * The current state of the table id generator.+--+-- * The current state of the variable id generator.+--+data TransformState = TS+ { multiParentNodes :: IntMap.IntMap ( ExternalReference+ , [String]+ )+ , tableIdGen :: ExternalReference+ , aliasIdGen :: Int+ , varIdGen :: InternalReference+ }++-- | The initial state.+sInitial :: TransformState+sInitial = TS IntMap.empty 0 0 0++-- | Adds a new binding to the state.+sAddBinding :: C.AlgNode -- ^ The key as a node with multiple parents.+ -> ( ExternalReference+ , [String]+ ) -- ^ Name of the reference and its columns.+ -> TransformState+ -> TransformState+sAddBinding node t st =+ st { multiParentNodes = IntMap.insert node t $ multiParentNodes st}++-- | Tries to look up a binding for a node.+sLookupBinding :: C.AlgNode+ -> TransformState+ -> Maybe (ExternalReference, [String])+sLookupBinding n = IntMap.lookup n . multiParentNodes++-- | The transform monad is used for transforming DAGs into dense tiles, it+-- is built from:+--+-- * A reader for the DAG+--+-- * A writer for outputting the dependencies+--+-- * A state for generating fresh names and maintain the mapping of nodes+--+type Transform = RWS TADag DependencyList TransformState++-- | A table expression id generator using the state within the+-- 'Transform' type.+freshTableId :: Transform ExternalReference+freshTableId = do+ st <- get++ let tid = tableIdGen st++ put $ st { tableIdGen = succ tid }++ return tid++freshAlias :: Transform String+freshAlias = do+ st <- get++ let aid = aliasIdGen st++ put $ st { aliasIdGen = succ aid }++ return $ 'a' : show aid++-- | A variable identifier generator.+freshVariableId :: Transform InternalReference+freshVariableId = do+ st <- get++ let vid = varIdGen st++ put $ st { varIdGen = succ vid }++ return vid++-- | Unpack values (or run computation).+runTransform :: Transform a+ -> TADag -- ^ The used DAG.+ -> TransformState -- ^ The inital state.+ -> (a, DependencyList)+runTransform = evalRWS++-- | Check if node has more than one parent.+isMultiReferenced :: C.AlgNode+ -> TADag+ -> Bool+isMultiReferenced n dag = case D.parents n dag of+ -- Has at least 2 parents.+ _:(_:_) -> True+ _ -> False++-- | Get the column schema of a 'TileNode'.+getSchemaTileTree :: TileTree -> [String]+getSchemaTileTree (ReferenceLeaf _ s) = s+getSchemaTileTree (TileNode _ body _) = getSchemaSelectStmt body++-- | Get the column schema of a 'Q.SelectStmt'.+getSchemaSelectStmt :: Q.SelectStmt -> [String]+getSchemaSelectStmt s = map Q.sName $ Q.selectClause s++-- | The result of the 'transform' function.+type TransformResult = ([TileTree], DependencyList)++-- | Transform a 'TADag', while swapping out repeatedly used sub expressions+-- (nodes with more than one parent).+-- A 'TADag' can have multiple root nodes, and therefore the function returns a+-- list of root tiles and their dependencies.+transform :: TADag -> TransformResult+transform dag = runTransform result dag sInitial+ where+ rootNodes = D.rootNodes dag+ result = mapM transformNode rootNodes++-- | This function basically checks for already referenced nodes with more than+-- one parent, returning a reference to already computed 'TileTree's.+transformNode :: C.AlgNode -> Transform TileTree+transformNode n = do++ op <- asks $ D.operator n++ -- allowBranch indicates whether multi reference nodes shall be split+ -- for this operator, resulting in multiple equal branches. (Treeify)+ let (allowBranch, transformOp) = case op of+ -- Ignore branching for nullary operators.+ (C.NullaryOp nop) -> (False, transformNullaryOp nop)+ (C.UnOp uop c) -> (True, transformUnOp uop c)+ (C.BinOp bop c0 c1) -> (True, transformBinOp bop c0 c1)+ (C.TerOp () _ _ _) -> $impossible++ multiRef <- asks $ isMultiReferenced n++ if allowBranch && multiRef+ then do+ -- Lookup whether there exists a binding for the node in the current+ -- state.+ possibleBinding <- gets $ sLookupBinding n++ case possibleBinding of+ -- If so, just return it.+ Just (b, s) -> return $ ReferenceLeaf b s+ -- Otherwise add it.+ Nothing -> do++ resultingTile <- transformOp++ -- Generate a name for the sub tree.+ tableId <- freshTableId++ -- Add the tree to the writer.+ tell $ DL.singleton (tableId, resultingTile)++ let schema = getSchemaTileTree resultingTile++ -- Add binding for this node (to prevent recalculation).+ modify $ sAddBinding n (tableId, schema)++ return $ ReferenceLeaf tableId schema+ else transformOp++transformNullaryOp :: A.NullOp -> Transform TileTree+transformNullaryOp (A.LitTable (tuples, typedSchema)) = do+ tableAlias <- freshAlias++ let -- Abstracts over the differences.+ tile otherFeatures tuples' wClause =+ TileNode (otherFeatures <> tableF)+ emptySelectStmt+ { Q.selectClause = columnsFromSchema tableAlias schema+ , Q.fromClause =+ [ Q.FPAlias (Q.FESubQuery $ Q.VQLiteral tuples')+ tableAlias+ $ Just schema+ ]+ , Q.whereClause = wClause+ }+ []++ return $ case tuples of+ [] -> tile (projectF <> filterF)+ [map (castedNull . snd) typedSchema]+ [Q.CEBase . Q.VEValue $ Q.VBoolean False]+ _ -> tile projectF+ (map (map translateLit) tuples)+ []+ where+ schema = map fst typedSchema+ castedNull ty = Q.CEBase $ Q.VECast (Q.CEBase $ Q.VEValue Q.VNull)+ (translateATy ty)+ translateLit = Q.CEBase . Q.VEValue . translateAVal++transformNullaryOp (A.TableRef (name, typedSchema, _)) = do+ tableAlias <- freshAlias++ return $ TileNode (projectF <> tableF)+ emptySelectStmt+ { -- Map the columns of the table reference to the given+ -- column names.+ Q.selectClause = columnsFromSchema tableAlias schema+ , Q.fromClause =+ [ Q.FPAlias (Q.FETableReference name)+ tableAlias+ -- Map to old column name.+ $ Just schema+ ]+ }+ []+ where+ schema = map fst typedSchema++-- | Abstraction for rank operators.+transformUnOpRank :: -- ExtendedExpr constructor.+ Q.WindowFunction+ -> (String, [A.SortSpec])+ -> C.AlgNode+ -> Transform TileTree+transformUnOpRank rankFun (name, sortList) =+ attachColFunUnOp colFun $ projectF <> windowFunctionF+ where+ colFun sClause = Q.SCAlias rankExpr name++ where+ rankExpr = Q.EEWinFun rankFun+ []+ (asWindowOrderExprList sClause sortList)+ Nothing++transformUnOp :: A.UnOp -> C.AlgNode -> Transform TileTree+transformUnOp (A.Serialize (mDescr, pos, payloadCols)) c = do+ (ctor, select, children) <- transformTerminated' c $ projectF <> sortF++ let inline :: String -> Q.ExtendedExpr+ inline = inlineEE $ Q.selectClause select++ -- Inline a column and alias the result.+ project :: String -> String -> Q.SelectColumn+ project col alias = Q.SCAlias (inline col) alias++ itemi i = "item" ++ show i+ + payloadProjs :: [Q.SelectColumn]+ payloadProjs =+ zipWith (\(A.PayloadCol col) i -> project col $ itemi i)+ payloadCols+ ([1..] :: [Integer])++ boundNames = map itemi [1..length payloadCols]++ inlineOrderBy col = if col `elem` boundNames+ then Q.EEBase $ Q.VEColumn col Nothing+ else inline col++ (posOrderList, posProjList) = case pos of+ A.NoPos -> ([], [])+ -- Sort and project (avoid inlining, because not+ -- necessary: The pos column will appear in the select+ -- clause and can be referenced in the order by clause).+ A.AbsPos col -> ([Q.EEBase $ mkCol "pos"], [(col, "pos")])+ -- Sort but do not project. It is not necessary because+ -- relative positions are not needed to reconstruct nested+ -- results. But: only inline those sorting columns that do+ -- not appear in the select clause. Names bound in the+ -- select clause are visible in the order by clause and+ -- can be referenced.+ A.RelPos cols -> (map inlineOrderBy cols, [])++ return $ ctor+ select+ { Q.selectClause =+ map (uncurry project) (descrProjAdder posProjList)+ ++ payloadProjs+ , -- Order by optional columns. Remove constant column expressions,+ -- since SQL99 defines different semantics.+ Q.orderByClause =+ map (`Q.OE` Q.Ascending)+ . filter affectsSortOrderEE+ . descrColAdder+ $ posOrderList+ }+ children+ where+ (descrColAdder, descrProjAdder) = case mDescr of+ Nothing -> (id, id)+ -- Project and sort. Since descr gets added as new alias we can use it+ -- in the ORDER BY clause (also avoid inlining).+ Just (A.DescrCol col) -> ( (:) $ Q.EEBase $ mkCol "descr"+ , (:) (col, "descr")+ )++++transformUnOp (A.RowNum (name, sortList, partExprs)) c =+ attachColFunUnOp colFun+ (projectF <> windowFunctionF)+ c+ where+ colFun sClause = Q.SCAlias rowNumExpr name+ where+ -- ROW_NUMBER() OVER (PARTITION BY p ORDER BY s)+ rowNumExpr = Q.EEWinFun Q.WFRowNumber+ (map (translateExprAE $ Just sClause) partExprs)+ (asWindowOrderExprList sClause sortList)+ Nothing++transformUnOp (A.WinFun ((name, fun), partExprs, sortExprs, mFrameSpec)) c =+ attachColFunUnOp colFun+ (projectF <> windowFunctionF)+ c++ where+ colFun sClause = Q.SCAlias winFunExpr name+ where+ winFunExpr = Q.EEWinFun (translateWindowFunction translateE fun)+ (map (translateExprAE $ Just sClause) partExprs)+ (asWindowOrderExprList sClause sortExprs)+ (fmap translateFrameSpec mFrameSpec)++ translateE = translateExprCE $ Just sClause++transformUnOp (A.RowRank inf) c = transformUnOpRank Q.WFDenseRank inf c+transformUnOp (A.Rank inf) c = transformUnOpRank Q.WFRank inf c+transformUnOp (A.Project projList) c = do+ + (ctor, select, children) <- transformTerminated' c projectF++ let -- Inlining is obligatory here, since we possibly eliminate referenced+ -- columns. ('translateExpr' inlines columns.)+ translateAlias :: (A.Attr, A.Expr) -> Q.SelectColumn+ translateAlias (col, expr) = Q.SCAlias translatedExpr col+ where+ translatedExpr = translateExprEE (Just $ Q.selectClause select) expr++ return $ ctor select+ -- Replace the select clause with the projection list.+ { Q.selectClause = map translateAlias projList }+ -- But use the old children.+ children++transformUnOp (A.Select expr) c = do++ (ctor, select, children) <- transformTerminated' c filterF+ + return $ ctor ( appendToWhere ( translateExprCE+ (Just $ Q.selectClause select)+ expr+ )+ select+ )+ children++transformUnOp (A.Distinct ()) c = do++ (ctor, select, children) <- transformTerminated' c dupElimF++ -- Keep everything but set distinct.+ return $ ctor select { Q.distinct = True } children++transformUnOp (A.Aggr (aggrs, partExprMapping)) c = do++ (ctor, select, children) <- transformTerminated' c $ projectF <> aggrAndGroupingF+ + let justSClause = Just $ Q.selectClause select+ translateE = translateExprCE justSClause+ -- Inlining here is obligatory, since we could eliminate referenced+ -- columns. (This is similar to projection.)+ aggrToEE (a, n) = + Q.SCAlias ( let (fun, optExpr) = translateAggrType a+ in Q.EEAggrExpr+ $ Q.AEAggregate (liftM translateE optExpr)+ fun+ )+ n++ partColumnExprs = map (second translateE) partExprMapping+ partExtendedExprs = map (second $ translateExprEE $ justSClause)+ partExprMapping+++ wrapSCAlias (name, extendedExpr)+ =+ Q.SCAlias extendedExpr name++ return $ ctor select+ { Q.selectClause =+ map wrapSCAlias partExtendedExprs+ ++ map aggrToEE aggrs+ , -- Since SQL treats numbers in the group by clause as+ -- column indices, filter them out. (They do not change+ -- the semantics anyway.)+ Q.groupByClause =+ filter affectsSortOrderCE $ map snd partColumnExprs+ }+ children++-- | Generates a new 'TileTree' by attaching a column, generated by a function+-- taking the select clause.+attachColFunUnOp :: ([Q.SelectColumn] -> Q.SelectColumn)+ -> FeatureSet+ -> C.AlgNode+ -> Transform TileTree+attachColFunUnOp colFun opFeatures c = do++ (ctor, select, children) <- transformTerminated' c opFeatures++ let sClause = Q.selectClause select++ -- Attach a column to the select clause generated by the+ -- given function.+ return $ case colFun sClause of+ col@(Q.SCAlias _ name) ->+ ctor select { Q.selectClause = col : pruneCol name sClause }+ children+ col@Q.SCExpr{} -> + ctor select { Q.selectClause = col : sClause }+ children++pruneCol :: String -> [Q.SelectColumn] -> [Q.SelectColumn]+pruneCol n cols = filter namePred cols+ where+ namePred (Q.SCAlias _ n') | n == n' = False+ namePred _ = True++-- | Abstracts over binary set operation operators.+transformBinSetOp :: Q.SetOperation+ -> C.AlgNode+ -> C.AlgNode+ -> Transform TileTree+transformBinSetOp setOp c0 c1 = do++ -- Use one tile to get the schema information.+ (_, select0, children0) <- transformTerminated c0 noneF+ (_, select1, children1) <- transformTerminated c1 noneF++ -- Impose a canonical order on entries in the SELECT clauses to+ -- ensure that schemata of the set operator inputs match.+ let select0' = select0 { Q.selectClause = sortWith Q.sName $ Q.selectClause select0 }+ select1' = select1 { Q.selectClause = sortWith Q.sName $ Q.selectClause select1 }++ tableAlias <- freshAlias++ -- Take the schema of the first one, but could also be from the second one,+ -- since we assume they are equal.+ let schema = getSchemaSelectStmt select0'++ return $ TileNode (projectF <> tableF)+ emptySelectStmt+ { Q.selectClause =+ columnsFromSchema tableAlias schema+ , Q.fromClause =+ [ Q.FPAlias ( Q.FESubQuery+ $ Q.VQBinarySetOperation+ (Q.VQSelect select0')+ (Q.VQSelect select1')+ setOp+ )+ tableAlias+ $ Just schema+ ]+ }+ $ children0 ++ children1++-- | Perform a cross join between two nodes.+transformBinCrossJoin :: C.AlgNode+ -> C.AlgNode+ -> Transform ( FeatureSet+ , Q.SelectStmt+ , TileChildren+ )+transformBinCrossJoin c0 c1 = do++ (childFeatures0, select0, children0) <- transformF c0+ (childFeatures1, select1, children1) <- transformF c1++ -- We can simply concatenate everything, because all things are prefixed and+ -- cross join is associative.+ return ( mconcat [childFeatures0, childFeatures1, opFeatures]+ , emptySelectStmt+ { Q.selectClause =+ Q.selectClause select0 ++ Q.selectClause select1+ , Q.fromClause =+ Q.fromClause select0 ++ Q.fromClause select1+ , Q.whereClause = Q.whereClause select0+ ++ Q.whereClause select1+ }+ , children0 ++ children1+ )+ where+ transformF c = transformTerminated c opFeatures+ opFeatures = projectF <> tableF <> filterF++transformBinOp :: A.BinOp+ -> C.AlgNode+ -> C.AlgNode+ -> Transform TileTree+transformBinOp (A.Cross ()) c0 c1 = do+ (f, s, c) <- transformBinCrossJoin c0 c1+ return $ TileNode f s c++transformBinOp (A.EqJoin (lName, rName)) c0 c1 = do++ (childrenFeatures, select, children) <- transformBinCrossJoin c0 c1++ let sClause = Q.selectClause select+ cond = Q.CEBase $ Q.VEBinApp Q.BFEqual (inlineCE sClause lName)+ $ inlineCE sClause rName++ -- 'transformBinCrossJoin' already has the 'filterF' feature.+ return $ TileNode childrenFeatures (appendToWhere cond select) children+++transformBinOp (A.ThetaJoin conditions) c0 c1 = do++ when (null conditions) $impossible++ (childrenFeatures, select, children) <- transformBinCrossJoin c0 c1++ let sClause = Q.selectClause select+ conds = map f conditions+ f = translateJoinCond sClause sClause++ return $ TileNode childrenFeatures+ (appendAllToWhere conds select)+ children++transformBinOp (A.SemiJoin cs) c0 c1 =+ transformExistsJoin cs c0 c1 id+transformBinOp (A.AntiJoin cs) c0 c1 =+ transformExistsJoin cs c0 c1 (Q.CEBase . Q.VENot)+transformBinOp (A.DisjUnion ()) c0 c1 =+ transformBinSetOp Q.SOUnionAll c0 c1+transformBinOp (A.Difference ()) c0 c1 =+ transformBinSetOp Q.SOExceptAll c0 c1++transformExistsJoin :: [(A.Expr, A.Expr, A.JoinRel)]+ -> C.AlgNode + -> C.AlgNode+ -> (Q.ColumnExpr -> Q.ColumnExpr)+ -> Transform TileTree+transformExistsJoin conditions c0 c1 wrapFun = do++ when (null conditions) $impossible++ (ctor0, select0, children0) <- transformTerminated' c0 filterF++ -- Ignore operator features, since it will be nested and therefore+ -- terminated.+ (_, select1, children1) <- transformTerminated c1 noneF++ let ctor s = ctor0 s $ children0 ++ children1+ + -- Split the conditions into the first equality condition found and the+ -- remaining ones.+ case foldr findEq (Nothing, []) conditions of+ -- We did not find an equality condition, use the EXISTS construct.+ (Nothing, _) -> do+ -- TODO in case we do not have merge conditions we can simply use+ -- the unmergeable but less nested select stmt on the right side++ let outerCond = wrapFun . Q.CEBase+ . Q.VEExists+ $ Q.VQSelect innerSelect+ innerSelect = appendAllToWhere innerConds select1+ innerConds = map f conditions+ f = translateJoinCond (Q.selectClause select0)+ $ Q.selectClause select1++ return $ ctor (appendToWhere outerCond select0)+ -- We did find an equality condition, use it with the IN construct.+ (Just (l, r), conditions') -> do+ + let -- Embedd the right query into the where clause of the left one.+ leftCond =+ wrapFun . Q.CEBase+ . Q.VEIn (translateExprCE (Just lSClause) l)+ $ rightSelect'+ + -- If the nested query is a simple selection from a+ -- literal table, use the literal table directly:+ -- SELECT t.c FROM (VALUES ...) AS t(c)+ -- =>+ -- VALUES ...+ rightSelect' = + case rightSelect of+ Q.VQSelect + (Q.SelectStmt+ [Q.SCExpr (Q.EEBase (Q.VEColumn colName (Just tabName)))] + False + [Q.FPAlias (Q.FESubQuery (Q.VQLiteral rows)) tabName' (Just [colName'])]+ []+ []+ []) | colName == colName' && tabName == tabName' -> Q.VQLiteral rows+ _ -> rightSelect+ + -- Embedd all conditions in the right select, and set select+ -- clause to the right part of the equal join condition.+ rightSelect = Q.VQSelect $ appendAllToWhere innerConds select1+ { Q.selectClause = [rightSCol] }+ innerConds = map f conditions'+ f = translateJoinCond lSClause rSClause+ rightSCol = Q.SCExpr (translateExprEE (Just rSClause) r)+ lSClause = Q.selectClause select0+ rSClause = Q.selectClause select1++ return $ ctor (appendToWhere leftCond select0)+ where+ -- Tries to extract a join condition for usage in the IN sql construct.+ findEq c (Just eqCols, r) = (Just eqCols, c:r)+ findEq c@(left, right, j) (Nothing, r) = case j of+ A.EqJ -> (Just (left, right), r)+ _ -> (Nothing, c:r)++-- | Terminates a SQL fragment when suggested. Returns the resulting+-- 'FeatureSet' of the child, the 'Q.SelectStmt' and its children.+transformTerminated :: C.AlgNode+ -> FeatureSet+ -> Transform (FeatureSet, Q.SelectStmt, TileChildren)+transformTerminated n topFs = do+ tile <- transformNode n+ + case tile of+ TileNode bottomFs body children+ | topFs `terminatesOver` bottomFs -> do+ tableAlias <- freshAlias++ let schema = getSchemaSelectStmt body++ return ( projectF <> tableF+ , emptySelectStmt+ { Q.selectClause =+ columnsFromSchema tableAlias schema+ , Q.fromClause =+ [mkSubQuery body tableAlias $ Just schema]+ }+ , children+ )+ | otherwise ->+ return (bottomFs, body, children)+ ReferenceLeaf r s -> do+ (sel, cs) <- embedExternalReference r s+ return (projectF <> tableF, sel, cs)++-- | Does the same as 'transformTerminated', but further handles combining of+-- the 'FeatureSet' and applies it to the constructor.+transformTerminated' :: C.AlgNode+ -> FeatureSet+ -> Transform ( Q.SelectStmt -> TileChildren -> TileTree+ , Q.SelectStmt+ , TileChildren+ )+transformTerminated' n topFs = do+ (fs, select, cs) <- transformTerminated n topFs+ return (TileNode $ fs <> topFs, select, cs)++-- | Embeds an external reference into a 'Q.SelectStmt'.+embedExternalReference :: ExternalReference+ -> [String]+ -> Transform (Q.SelectStmt, TileChildren)+embedExternalReference extRef schema = do++ tableAlias <- freshAlias+ varId <- freshVariableId++ return ( emptySelectStmt+ { -- Use the schema to construct the select clause.+ Q.selectClause =+ columnsFromSchema tableAlias schema+ , Q.fromClause =+ [Q.FPAlias (Q.FEVariable varId) tableAlias $ Just schema]+ }+ , [(varId, ReferenceLeaf extRef schema)]+ )++-- | Generate a select clause with column names from a schema and a prefix.+columnsFromSchema :: String -> [String] -> [Q.SelectColumn]+columnsFromSchema p = map $ asSelectColumn p++-- | Creates 'Q.SelectColumn' which points at a prefixed column with the same+-- name.+asSelectColumn :: String+ -> String+ -> Q.SelectColumn+asSelectColumn tablePrefix columnName =+ Q.SCAlias (Q.EEBase $ mkPCol tablePrefix columnName) columnName++-- Translates a '[A.SortSpec]' into a '[Q.WindowOrderExpr]'. Column names will+-- be inlined as a 'Q.AggrExpr', constant ones will be discarded.+asWindowOrderExprList :: [Q.SelectColumn]+ -> [A.SortSpec]+ -> [Q.WindowOrderExpr]+asWindowOrderExprList sClause si =+ filter (affectsSortOrderAE . Q.woExpr)+ $ translateSortInf si (translateExprAE $ Just sClause)++-- | Search the select clause for a specific column definition and return it as+-- 'Q.ColumnExpr'.+inlineCE :: [Q.SelectColumn]+ -> String+ -> Q.ColumnExpr+inlineCE sClause col =+ fromMaybe (Q.CEBase $ Q.VEColumn col Nothing)+ $ convertEEtoCE $ inlineEE sClause col+++-- | Search the select clause for a specific column definition and return it as+-- 'Q.AggrExpr'.+inlineAE :: [Q.SelectColumn]+ -> String+ -> Q.AggrExpr+inlineAE sClause col =+ fromMaybe (Q.AEBase $ Q.VEColumn col Nothing)+ $ convertEEtoAE $ inlineEE sClause col++-- | Search the select clause for a specific column definition and return it as+-- 'Q.ExtendedExpr'.+inlineEE :: [Q.SelectColumn]+ -> String+ -> Q.ExtendedExpr+inlineEE sClause col =+ fromMaybe (Q.EEBase $ mkCol col) $ foldr f Nothing sClause+ where+ f sc r = case sc of+ Q.SCAlias expr alias | col == alias -> return expr+ _ -> r++-- | Generic base converter for the value expression template. Since types do+-- not have equal functionality, conversion can fail.+convertEEBaseTemplate :: (Q.ExtendedExpr -> Maybe a)+ -> Q.ExtendedExprBase+ -> Maybe (Q.ValueExprTemplate a)+convertEEBaseTemplate convertEEBaseRec eeb = case eeb of+ Q.VEValue v -> return $ Q.VEValue v+ Q.VEColumn n p -> return $ Q.VEColumn n p+ Q.VECast rec t -> do+ e <- convertEEBaseRec rec+ return $ Q.VECast e t++ Q.VEBinApp f lrec rrec -> do+ l <- convertEEBaseRec lrec+ r <- convertEEBaseRec rrec+ return $ Q.VEBinApp f l r++ Q.VEUnApp f rec -> do+ e <- convertEEBaseRec rec+ return $ Q.VEUnApp f e++ Q.VENot rec -> do+ e <- convertEEBaseRec rec+ return $ Q.VENot e++ Q.VEExists q -> return $ Q.VEExists q+ Q.VEIn rec q -> do+ e <- convertEEBaseRec rec+ return $ Q.VEIn e q+ Q.VECase crec trec erec -> do+ c <- convertEEBaseRec crec+ t <- convertEEBaseRec trec+ e <- convertEEBaseRec erec++ return $ Q.VECase c t e++-- | Converts an 'Q.ExtendedExpr' to a 'Q.ColumnExpr', if possible.+convertEEtoCE :: Q.ExtendedExpr -> Maybe Q.ColumnExpr+convertEEtoCE ee = case ee of+ Q.EEBase eeb -> do+ ceb <- convertEEBaseTemplate convertEEtoCE eeb+ return $ Q.CEBase ceb+ _ -> Nothing++-- | Converts an 'Q.ExtendedExpr' to a 'Q.AggrExpr', if possible.+convertEEtoAE :: Q.ExtendedExpr -> Maybe Q.AggrExpr+convertEEtoAE ee = case ee of+ Q.EEBase eeb -> do+ aeb <- convertEEBaseTemplate convertEEtoAE eeb+ return $ Q.AEBase aeb++ Q.EEAggrExpr ae -> return ae++ _ -> Nothing++-- | Shorthand to make an unprefixed column.+mkCol :: String+ -> Q.ValueExprTemplate a+mkCol c = Q.VEColumn c Nothing++appendToWhere :: Q.ColumnExpr -- ^ The expression added with logical and.+ -> Q.SelectStmt -- ^ The select statement to add to.+ -> Q.SelectStmt -- ^ The result.+appendToWhere cond select =+ select { Q.whereClause = cond : Q.whereClause select }++-- | Append predicate expressions to the WHERE clause of a select+-- statement.+appendAllToWhere :: [Q.ColumnExpr]+ -> Q.SelectStmt+ -> Q.SelectStmt+appendAllToWhere conds select =+ select { Q.whereClause = conds ++ Q.whereClause select }++-- | Translate 'A.JoinRel' into 'Q.BinaryFunction'.+translateJoinRel :: A.JoinRel+ -> Q.BinaryFunction+translateJoinRel rel = case rel of+ A.EqJ -> Q.BFEqual+ A.GtJ -> Q.BFGreaterThan+ A.GeJ -> Q.BFGreaterEqual+ A.LtJ -> Q.BFLowerThan+ A.LeJ -> Q.BFLowerEqual+ A.NeJ -> Q.BFNotEqual++translateFrameSpec :: A.FrameBounds -> Q.FrameSpec+translateFrameSpec (A.HalfOpenFrame fs) = Q.FHalfOpen $ translateFrameStart fs+translateFrameSpec (A.ClosedFrame fs fe) = Q.FClosed (translateFrameStart fs)+ (translateFrameEnd fe)++translateFrameStart :: A.FrameStart -> Q.FrameStart+translateFrameStart A.FSUnboundPrec = Q.FSUnboundPrec+translateFrameStart (A.FSValPrec i) = Q.FSValPrec i+translateFrameStart A.FSCurrRow = Q.FSCurrRow++translateFrameEnd :: A.FrameEnd -> Q.FrameEnd+translateFrameEnd A.FEUnboundFol = Q.FEUnboundFol+translateFrameEnd (A.FEValFol i) = Q.FEValFol i+translateFrameEnd A.FECurrRow = Q.FECurrRow++translateWindowFunction :: (A.Expr -> Q.ColumnExpr) -> A.WinFun -> Q.WindowFunction+translateWindowFunction translateExpr wfun = case wfun of+ A.WinMax e -> Q.WFMax $ translateExpr e+ A.WinMin e -> Q.WFMin $ translateExpr e+ A.WinSum e -> Q.WFSum $ translateExpr e+ A.WinAvg e -> Q.WFAvg $ translateExpr e+ A.WinAll e -> Q.WFAll $ translateExpr e+ A.WinAny e -> Q.WFAny $ translateExpr e+ A.WinFirstValue e -> Q.WFFirstValue $ translateExpr e+ A.WinLastValue e -> Q.WFLastValue $ translateExpr e+ A.WinCount -> Q.WFCount++translateAggrType :: A.AggrType+ -> (Q.AggregateFunction, Maybe A.Expr)+translateAggrType aggr = case aggr of+ A.Avg e -> (Q.AFAvg, Just e)+ A.Max e -> (Q.AFMax, Just e)+ A.Min e -> (Q.AFMin, Just e)+ A.Sum e -> (Q.AFSum, Just e)+ A.Count -> (Q.AFCount, Nothing)+ A.All e -> (Q.AFAll, Just e)+ A.Any e -> (Q.AFAny, Just e)++translateExprValueExprTemplate :: (Maybe [Q.SelectColumn] -> A.Expr -> a)+ -> (Q.ValueExprTemplate a -> a)+ -> ([Q.SelectColumn] -> String -> a)+ -> Maybe [Q.SelectColumn]+ -> A.Expr+ -> a+translateExprValueExprTemplate rec wrap inline optSelectClause expr =+ case expr of+ A.IfE c t e ->+ wrap $ Q.VECase (rec optSelectClause c)+ (rec optSelectClause t)+ (rec optSelectClause e)+ + A.BinAppE f e1 e2 ->+ wrap $ Q.VEBinApp (translateBinFun f)+ (rec optSelectClause e1)+ $ rec optSelectClause e2+ A.UnAppE f e ->+ wrap $ case f of+ A.Not -> Q.VENot tE+ A.Cast t -> Q.VECast tE $ translateATy t+ A.Sin -> Q.VEUnApp Q.UFSin tE+ A.Cos -> Q.VEUnApp Q.UFCos tE+ A.Tan -> Q.VEUnApp Q.UFTan tE+ A.ASin -> Q.VEUnApp Q.UFASin tE+ A.ACos -> Q.VEUnApp Q.UFACos tE+ A.ATan -> Q.VEUnApp Q.UFATan tE+ A.Sqrt -> Q.VEUnApp Q.UFSqrt tE+ A.Log -> Q.VEUnApp Q.UFLog tE+ A.Exp -> Q.VEUnApp Q.UFExp tE+ A.SubString from to -> Q.VEUnApp (Q.UFSubString from to) tE++ where+ tE = rec optSelectClause e++ A.ColE n -> case optSelectClause of+ Just s -> inline s n+ Nothing -> wrap $ mkCol n+ A.ConstE v -> wrap $ Q.VEValue $ translateAVal v++translateExprCE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ColumnExpr+translateExprCE = translateExprValueExprTemplate translateExprCE Q.CEBase inlineCE++translateExprEE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ExtendedExpr+translateExprEE = translateExprValueExprTemplate translateExprEE Q.EEBase inlineEE++translateExprAE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.AggrExpr+translateExprAE = translateExprValueExprTemplate translateExprAE Q.AEBase inlineAE++translateBinFun :: A.BinFun -> Q.BinaryFunction+translateBinFun f = case f of+ A.Gt -> Q.BFGreaterThan+ A.Lt -> Q.BFLowerThan+ A.GtE -> Q.BFGreaterEqual+ A.LtE -> Q.BFLowerEqual+ A.Eq -> Q.BFEqual+ A.NEq -> Q.BFNotEqual+ A.And -> Q.BFAnd+ A.Or -> Q.BFOr+ A.Plus -> Q.BFPlus+ A.Minus -> Q.BFMinus+ A.Times -> Q.BFTimes+ A.Div -> Q.BFDiv+ A.Modulo -> Q.BFModulo+ A.Contains -> Q.BFContains+ A.SimilarTo -> Q.BFSimilarTo+ A.Like -> Q.BFLike+ A.Concat -> Q.BFConcat++-- | Translate sort information into '[Q.WindowOrderExpr]', using the column+-- function, which takes a 'String'.+translateSortInf :: [A.SortSpec]+ -> (A.Expr -> Q.AggrExpr)+ -> [Q.WindowOrderExpr]+translateSortInf sortInfos colFun = map toWOE sortInfos+ where+ toWOE (n, d) = Q.WOE (colFun n) (translateSortDir d)+++-- | Translate a single join condition into it's 'Q.ColumnExpr' equivalent.+-- 'A.Expr' contained within the join condition are inlined with the according+-- select clauses.+translateJoinCond :: [Q.SelectColumn] -- ^ Left select clause.+ -> [Q.SelectColumn] -- ^ Right select clause.+ -> (A.Expr, A.Expr, A.JoinRel)+ -> Q.ColumnExpr+translateJoinCond lSelectClause rSelectClause (l, r, j) =+ Q.CEBase $ Q.VEBinApp (translateJoinRel j)+ (translateExprCE (Just lSelectClause) l)+ (translateExprCE (Just rSelectClause) r)++translateSortDir :: A.SortDir -> Q.SortDirection+translateSortDir d = case d of+ A.Asc -> Q.Ascending+ A.Desc -> Q.Descending++translateAVal :: A.AVal -> Q.Value+translateAVal v = case v of+ A.VInt i -> Q.VInteger i+ A.VStr s -> Q.VText s+ A.VBool b -> Q.VBoolean b+ A.VDouble d -> Q.VDoublePrecision d+ A.VDec d -> Q.VDecimal d+ A.VNat n -> Q.VInteger n++translateATy :: A.ATy -> Q.DataType+translateATy t = case t of+ A.AInt -> Q.DTInteger+ A.AStr -> Q.DTText+ A.ABool -> Q.DTBoolean+ A.ADec -> Q.DTDecimal+ A.ADouble -> Q.DTDoublePrecision+ A.ANat -> Q.DTInteger+
+ src/Database/Algebra/SQL/Tile/Flatten.hs view
@@ -0,0 +1,138 @@+-- | When the tiles have been transformed, all children of 'TileNode' are+-- references and every tree contains just a single node. This is where this+-- module is used, it removes the redundant type structure.+-- It also provides the possibilty to change the transformation behaviour, but+-- the tile merging is much worse, since we lost a lot of useful information.+--+-- This can be used as a finishing step for materialization or as an+-- intermediate step, since it provides an interface for 'String' and a+-- generic interface which takes a materializer and a substituter.+module Database.Algebra.SQL.Tile.Flatten+ ( flattenTransformResultWith+ , flattenTransformResult+ , FlatTile+ ) where++import qualified Data.IntMap.Lazy as IntMap+ ( empty+ , insert+ , lookup+ )+import qualified Data.MultiSet as MultiSet+ ( MultiSet+ , empty+ , insert+ , union+ , singleton+ )+import qualified Data.DList as DL+ ( toList+ )+import Data.Maybe (fromMaybe)++import qualified Database.Algebra.SQL.Query as Q+import Database.Algebra.SQL.Query.Substitution+import Database.Algebra.SQL.Query.Util+ ( emptySelectStmt+ , mkPCol+ )+import Database.Algebra.SQL.Termination+import Database.Algebra.SQL.Tile+++-- TODO error used in lookup++-- | A flat tile containing:+--+-- * the body of the tile+--+-- * a multiset of a type which identifies a referenceable flat tile+--+type FlatTile a = (Q.SelectStmt, MultiSet.MultiSet a)++-- | Flatten a transform result using SQL identifiers directly.+flattenTransformResult :: ([TileTree], DependencyList)+ -> ([FlatTile String], [(String, FlatTile String)])+flattenTransformResult =+ flattenTransformResultWith m s+ where -- Materializes a table reference as string (a SQL identifier).+ m tableRef = 't' : show tableRef+ s = Q.FETableReference++-- | Flatten the transformed result and apply the given functions where+-- possible.+-- The materializer should produce the desired representation, and the+-- substituter should produce expressions which can be substituted as+-- 'Q.FromExpr'.+flattenTransformResultWith :: Ord a+ => (ExternalReference -> a) -- ^ The materializer.+ -> (a -> Q.FromExpr) -- ^ The substituter.+ -> ([TileTree], DependencyList)+ -> ([FlatTile a], [(a, FlatTile a)])+flattenTransformResultWith materializer substituter (tiles, deps) =+ ( map (flattenTileTreeWith materializer substituter) tiles+ , map f $ DL.toList deps+ )+ where f (extRef, tile) =+ ( materializer extRef+ , flattenTileTreeWith materializer substituter tile+ )++flattenTileTreeWith :: Ord a+ => (ExternalReference -> a)+ -> (a -> Q.FromExpr)+ -> TileTree+ -> FlatTile a+flattenTileTreeWith materializer substituter (TileNode fs body children) =+ flattenTileNodeWith materializer substituter fs body children++-- This case should never happen, but is provided for completeness.+flattenTileTreeWith materializer substituter (ReferenceLeaf tableId s) =+ ( emptySelectStmt+ { Q.selectClause = map f s+ , Q.fromClause = + [Q.FPAlias (substituter alias) aliasName $ Just s]+ }+ , MultiSet.singleton alias+ )+ where f col = Q.SCAlias (Q.EEBase $ mkPCol aliasName col) col+ aliasName = "tmpAlias"+ alias = materializer tableId++flattenTileNodeWith :: Ord a+ => (ExternalReference -> a)+ -> (a -> Q.FromExpr)+ -> FeatureSet+ -> Q.SelectStmt+ -> TileChildren+ -> FlatTile a+flattenTileNodeWith materializer substituter _ body children =+ -- Merge the replacements into the body.+ ( replaceReferencesSelectStmt lookupFun body+ , externalReferences+ )+ where lookupFun v =+ fromMaybe (error "missing reference while replacing")+ $ IntMap.lookup v bodySubstitutes+ (bodySubstitutes, externalReferences) =+ foldr f (IntMap.empty, MultiSet.empty) children++ f (ref, tile) (substitutes, refs) = case tile of+ -- There is probably no better way to merge here, because we have no+ -- information about where the references are located. (TODO lookup+ -- is possible, but expensive)+ TileNode m b c ->+ let (b', externalRefs) =+ flattenTileNodeWith materializer substituter m b c+ in+ ( IntMap.insert ref (Q.FESubQuery $ Q.VQSelect b') substitutes+ , MultiSet.union externalRefs refs+ )++ -- Most of the time this case should be taken.+ ReferenceLeaf tableId _ ->+ ( IntMap.insert ref (substituter alias) substitutes+ , MultiSet.insert alias refs+ )+ where alias = materializer tableId+
+ src/Database/Algebra/SQL/Tools/Gen.hs view
@@ -0,0 +1,489 @@+module Main where++import Control.Monad (forM_,+ when)+import qualified Data.IntMap as IntMap (fromList)+import System.Console.GetOpt (ArgDescr (NoArg, ReqArg, OptArg), ArgOrder (RequireOrder), OptDescr (Option),+ getOpt,+ usageInfo)+import System.Environment (getArgs)++import qualified Database.Algebra.Dag as D+import qualified Database.Algebra.Dag.Common as C+import qualified Database.Algebra.Table.Lang as A++import Database.Algebra.SQL.Compatibility+import Database.Algebra.SQL.File+import Database.Algebra.SQL.Materialization+import qualified Database.Algebra.SQL.Materialization.Combined as Combined+import Database.Algebra.SQL.Materialization.CTE as CTE+import Database.Algebra.SQL.Materialization.TemporaryTable as TemporaryTable+import qualified Database.Algebra.SQL.Tile as T+import Database.Algebra.SQL.Util+++test :: T.TADag+test = D.mkDag ( IntMap.fromList [ (0, C.BinOp (A.Cross ()) 1 2)+ , (1, C.UnOp (A.Project [("x", A.ColE "y")]) 4)+ , (2, C.BinOp (A.Cross ()) 1 3)+ , (4, C.NullaryOp $ A.LitTable+ ( [[A.VStr "foo"]]+ , [("y", A.AStr)]+ )+ )+ , (3, C.UnOp (A.Project [("z", A.ColE "y")]) 4)+ , (5, C.UnOp (A.Project [("x", A.ColE "y")]) 4)+ ]+ )+ [0, 5]++-- TODO when using mutiple root nodes the result gets computed multiple times,+-- maybe save every computed tile in the state part of the transform monad for a node.+g1 :: T.TADag+g1 = D.mkDag ( IntMap.fromList [ (0, C.UnOp (A.Project [("result", A.ColE "str")]) 1)+ , (1, C.UnOp (A.Select eq) 2)+ , (2, C.NullaryOp $ A.LitTable+ ( [ [A.VStr "0"]+ , [A.VStr "1"]+ , [A.VStr "2"]+ ]+ , [("str", A.AStr)]+ )+ )+ ]++ )+ [0]+ where eq = A.BinAppE A.Eq (A.BinAppE A.Plus cast $ A.ConstE $ A.VInt 41)+ $ A.ConstE $ A.VInt 42+ cast = A.UnAppE (A.Cast A.AInt) $ A.ColE "str"++g2 :: T.TADag+g2 = D.mkDag ( IntMap.fromList [ (0, C.UnOp (A.Project [ ( "result"+ , A.BinAppE A.Plus+ (A.ColE "a")+ $ A.ColE "b"+ )+ ]) 2)+ , (2, C.BinOp (A.EqJoin ("u", "v")) 3 4)+ , (3, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 0, A.VInt 50]+ , [A.VInt 1, A.VInt 60]+ ]+ , [("u", A.AInt), ("a", A.AInt)]+ )+ )+ )+ , (4, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 0, A.VInt 4]+ , [A.VInt 1, A.VInt 23]+ ]+ , [("v", A.AInt), ("b", A.AInt)]+ )+ )+ )+ ]+ )+ [0]++--g3 :: T.TADag+--g3 = D.mkDag ( IntMap.fromList [ (0, C.BinOp (A.EqJoin ("a", "b")) 1 2)+-- , (1, C.UnOp (A.Proj [("a", "u")]) 3)+-- , (2, C.UnOp (A.Proj [("b", "u")]) 3)+-- , (3, C.NullaryOp ( A.LitTable+-- [ [A.VInt 0]+-- ]+-- [("u", A.AInt)]+-- )+-- )+-- ]+-- )+-- [0, 1, 2]+--+--g4 :: T.TADag+--g4 = D.mkDag ( IntMap.fromList [ (0, C.UnOp (A.Proj [("qsum", "qsum"), ("id", "id")]) 1)+-- , (1, C.UnOp (A.Aggr ([(A.Sum "quantity", "qsum")], Just "id")) 2)+-- , (2, C.NullaryOp ( A.LitTable+-- [ [A.VInt 0, A.VInt 2]+-- , [A.VInt 0, A.VInt 10]+-- , [A.VInt 1, A.VInt 100]+-- , [A.VInt 1, A.VInt 20]+-- ]+-- [("id", A.AInt), ("quantity", A.AInt)]+-- )+-- )+-- ]+-- )+-- [0]+--+--g5 :: T.TADag+--g5 = D.mkDag ( IntMap.fromList [ (0, C.UnOp (A.Proj [("y", "id")]) 1)+-- , (1, C.UnOp (A.Proj [("y", "id")]) 3)+-- , (2, C.UnOp (A.Proj [("y", "id")]) 3)+-- , (3, C.NullaryOp ( A.TableRef+-- ( "foo"+-- , [ ("id", "id", A.AInt)+-- , ("bla", "bla", A.AStr)+-- ]+-- , []+-- )+-- )+-- )+-- ]+-- )+-- [0, 1]+--++g6 :: T.TADag+g6 = D.mkDag ( IntMap.fromList [ (0, C.BinOp ( A.AntiJoin [ (A.ColE "a", A.ColE "c", A.EqJ)+ , (A.ColE "b", A.ColE "d", A.LtJ)+ ]+ )+ 1+ 2+ )+ , (1, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("a", A.AInt), ("b", A.AInt)]+ )+ )+ )+ , (2, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("c", A.AInt), ("d", A.AInt)]+ )+ )+ )+ ]+ )+ [0]++g7 :: T.TADag+g7 = D.mkDag ( IntMap.fromList [ (0, C.BinOp ( A.SemiJoin [ (A.ColE "a", A.ColE "c", A.EqJ)+ , (A.ColE "b", A.ColE "d", A.LtJ)+ ]+ )+ 1+ 2+ )+ , (1, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("a", A.AInt), ("b", A.AInt)]+ )+ )+ )+ , (2, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("c", A.AInt), ("d", A.AInt)]+ )+ )+ )+ ]+ )+ [0]++-- Should use EXISTS due to the lack of the equal join condition.+g8 :: T.TADag+g8 = D.mkDag ( IntMap.fromList [ (0, C.BinOp ( A.SemiJoin [ (A.ColE "b", A.ColE "d", A.LtJ)+ ]+ )+ 1+ 2+ )+ , (1, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("a", A.AInt), ("b", A.AInt)]+ )+ )+ )+ , (2, C.NullaryOp ( A.LitTable+ ( [ [A.VInt 1, A.VInt 2]+ , [A.VInt 1, A.VInt 1]+ ]+ , [("c", A.AInt), ("d", A.AInt)]+ )+ )+ )+ ]+ )+ [0]++g9 :: T.TADag+g9 = D.mkDag ( IntMap.fromList [ (0, C.UnOp p 2)+ , (1, C.UnOp p 2)+ , (2, C.UnOp p 4)+ , (3, C.UnOp p 4)+ , (4, C.UnOp p 5)+ , (5, C.BinOp eq 6 7)+ , (6, C.UnOp (pc "a") 8)+ , (7, C.UnOp p 8)+ , (8, C.UnOp p 9)+ , (9, C.NullaryOp ( A.LitTable ([], [("c", A.AInt), ("d", A.AInt)] ))+ )+ ]+ )+ [0, 1, 3]+ where p = pc "c"+ pc c = A.Project [(c, A.ColE "c")]+ eq = A.EqJoin ("a", "c")++-- | Tests whether different binding strategies for Materialization.Combined+-- work.+g10 :: T.TADag+g10 = D.mkDag ( IntMap.fromList [ (0, C.BinOp eq 1 1)+ , (1, C.BinOp eq 2 2)+ , (2, C.UnOp p 3)+ , (3, C.NullaryOp ( A.LitTable ([], [("c", A.AInt), ("d", A.AInt)] )))+ ]+ )+ [0]+ where p = pc "c"+ pc c = A.Project [(c, A.ColE "c")]+ eq = A.EqJoin ("c", "d")+++testGraphs :: [T.TADag]+testGraphs = singleTests ++ [test, g1, g2, g6, g7, g8, g9, g10] -- g3, g4, g5]++-- Test for single operator translation.+singleTests :: [T.TADag]+singleTests = [ tLitTable+ , tEmptyTable+ , tTableRef+ , tSerialize+ , tRowNum+ , tRowRank+ , tRank+ , tProject+ , tSelect+ , tDistinct+ , tAggr+ , tCross+ , tEqJoin+ , tThetaJoin+ , tSemiJoin+ , tAntiJoin+ , tDisjUnion+ , tDifference+ ]+ where+ joinInfo = [(A.ColE "a", A.ColE "c", A.EqJ), (A.ColE "b", A.ColE "d", A.LeJ)]+ sortInfo = [(A.ColE "a", A.Asc)]+ colTypes = [("a", A.AInt), ("b", A.AStr)]+ colTypes2 = [("c", A.AInt), ("d", A.AInt)]+ mapping op = [ (0, C.NullaryOp (A.LitTable ([], colTypes)))+ , (1, C.NullaryOp (A.LitTable ([], colTypes2)))+ , (2, op)+ ]+ singletonGraph :: A.TableAlgebra -> T.TADag+ singletonGraph op = D.mkDag ( IntMap.fromList $ mapping op+ )+ [2]+ -- nullary operators+ singletonN = singletonGraph . C.NullaryOp+ tLitTable =+ singletonN $ A.LitTable ([[A.VInt 0, A.VStr "test"]], colTypes)+ tEmptyTable = singletonN $ A.LitTable ([], colTypes)+ tTableRef = singletonN $ A.TableRef ("foo", colTypes, [])++ -- unary operators+ singletonU op = singletonGraph $ C.UnOp op 0++ tSerialize = singletonU (A.Serialize (Just $ A.DescrCol "a", A.NoPos, [A.PayloadCol "a"]))+ tRowNum = singletonU (A.RowNum ("c", sortInfo, [A.ColE "b"]))+ tRowRank = singletonU (A.RowRank ("c", sortInfo))+ tRank = singletonU (A.Rank ("c", sortInfo))+ tProject =+ singletonU+ $ A.Project [ ("x", A.ConstE $ A.VInt 0)+ , ("y", A.ColE "a")+ , ("z", A.UnAppE A.Not+ $ A.ConstE $ A.VBool False+ )+ ]+ -- TODO+ tSelect =+ singletonU $ A.Select $ A.ConstE $ A.VBool True+ tDistinct = singletonU $ A.Distinct ()+ tAggr =+ singletonU+ $ A.Aggr ([(A.Count, "count")], [("a", A.ColE "a")])++ -- binary operators+ singletonB op = singletonGraph $ C.BinOp op 0 1++ tCross = singletonB $ A.Cross ()+ tEqJoin = singletonB $ A.EqJoin ("a", "c")+ tThetaJoin = singletonB $ A.ThetaJoin joinInfo+ tSemiJoin = singletonB $ A.SemiJoin joinInfo+ tAntiJoin = singletonB $ A.AntiJoin joinInfo+ tDisjUnion = singletonB $ A.DisjUnion ()+ tDifference = singletonB $ A.Difference ()+++data Options = Options+ { optDot :: Bool+ , optRenderDot :: Bool+ , optDebug :: Bool+ , optHelp :: Bool+ , optMatFun :: MatFun+ , optFast :: Maybe (CompatMode -> T.TADag -> MatFun -> ShowS)+ , optDebugFun :: Maybe (CompatMode -> T.TADag -> MatFun -> String)+ , optCompatMode :: CompatMode+ }+defaultOptions :: Options+defaultOptions = Options False+ False+ False+ False+ CTE.materialize+ Nothing+ Nothing+ SQL99++-- idea from VLToX100.hs from DSH+options :: [OptDescr (Options -> Options)]+options = [ Option+ "p"+ ["print-dot"]+ (NoArg (\opt -> opt { optDot = True }))+ "Output each read directed acyclic graph as dot file"+ , Option+ "r"+ ["render-dot"]+ (NoArg (\opt -> opt { optDot = True, optRenderDot = True }))+ "Render each read directed acyclic graph as png"+ , Option+ "d"+ ["debug"]+ (OptArg handleDebug "<flags>")+ "Show debug output, where optional arguments can be\n\+ \composed of (trigger analyze and/or explain):\n\+ \ a | e"+ , Option+ "h"+ ["help"]+ (NoArg (\opt -> opt { optHelp = True }))+ "Show help"+ , Option+ "m"+ ["mat-strategy"]+ (ReqArg (\s opt -> opt { optMatFun = parseMatFun s }) "<strategy>")+ "Specify the type of materialization (defaults to cte):\n\+ \ lcte | cte | tmp | com | coml | comh"+ , Option+ "f"+ ["fast"]+ (OptArg handleFast "<optformat>")+ "Render a fast but ugly sql representation optional with formatting:\+ \ '' | 'f'"+ , Option+ "c"+ ["compat"]+ ( ReqArg (\s opt -> opt { optCompatMode = parseCompatMode s })+ "<mode>"+ )+ "Specify the compatibility mode (defaults to sql99):\n\+ \ sql99 | postgresql"+ ]+ where parseMatFun s = case s of+ "lcte" -> CTE.legacyMaterialize+ "cte" -> CTE.materialize+ "tmp" -> TemporaryTable.materialize+ "com" -> Combined.materialize+ "coml" ->+ Combined.materializeByBindingStrategy Combined.Lowest+ "comh" ->+ Combined.materializeByBindingStrategy Combined.Highest+ _ -> error $ "invalid materialization function '"+ ++ s+ ++ "'"++ parseCompatMode s = case s of+ "sql99" -> SQL99+ "postgresql" -> PostgreSQL+ _ -> error $ "invalid compatibility mode '"+ ++ s+ ++ "'"++ handleFast optArg opts =+ opts+ { optFast = Just $ case optArg of+ Nothing -> renderOutputCompact+ Just _ -> renderOutputPlain+ }++ handleDebug optArg opts =+ ( case optArg of+ Nothing -> opts+ Just os ->+ opts { optDebugFun = Just $ parseDebugStr os }+ )+ { optDebug = True }++ parseDebugStr os c = renderAdvancedDebugOutput c ('e' `elem` os)+ $ 'a' `elem` os+++main :: IO ()+main = do+ args <- getArgs++ let (funs, realArgs, errs) = getOpt RequireOrder options args+ usedOptions = foldr ($) defaultOptions funs++ case (optHelp usedOptions, not $ null errs) of+ -- not used the help option and no parse errors+ (False, False) -> do+ let debug = optDebug usedOptions+ matFun = optMatFun usedOptions+ compatMode = optCompatMode usedOptions+ output d = case optDebugFun usedOptions of+ Just f ->+ putStrLn $ f compatMode d matFun+ Nothing ->+ putShowSLn $ renderDebugOutput compatMode d matFun debug++ case realArgs of+ filenames@(_:_) ->+ mapM_ process filenames+ where process filename = do+ mDag <- readDagFromFile filename++ case mDag of+ Left err ->+ putStrLn err+ Right dag ->+ if optDot usedOptions+ then do+ let dotPath = filename ++ ".dot"+ pdfPath = filename ++ ".pdf"++ outputDot dotPath dag++ when (optRenderDot usedOptions)+ $ renderDot dotPath pdfPath+ else case optFast usedOptions of+ Just r ->+ putShowSLn $ r compatMode dag matFun+ Nothing -> output dag+ [] ->+ -- Run tests+ forM_ testGraphs $ \d -> output d++ -- show help when requested or wrong arguments given+ (_, hasInvalidArgs) -> do+ when hasInvalidArgs+ $ putStrLn $ "Invalid args: \n" ++ concatMap (" " ++) errs+ putStrLn $ usageInfo "Usage: Test [options] [files]" options+
+ src/Database/Algebra/SQL/Util.hs view
@@ -0,0 +1,98 @@+-- | This module abstracts over commonly used functions.+module Database.Algebra.SQL.Util+ ( renderOutputCompact+ , renderOutputPlain+ , renderDebugOutput+ , renderAdvancedDebugOutput+ , renderOutputDSH+ , renderOutputDSHWith+ , putShowSLn+ ) where++import Data.List (intersperse)++import qualified Database.Algebra.SQL.Render as R+import qualified Database.Algebra.SQL.Tile as T+import Database.Algebra.SQL.Materialization+import Database.Algebra.SQL.Materialization.Combined as C+import Database.Algebra.SQL.Query (Query)+import Database.Algebra.SQL.Compatibility++-- TODO include materialization strategy depending on compat mode++resultFromDAG :: T.TADag -> MatFun -> (T.TransformResult, ([Query], [Query]))+resultFromDAG dag matFun = (transformResult, matFun transformResult)+ where transformResult = T.transform dag++-- | Produces pretty output, optionally with debug information.+renderDebugOutput :: CompatMode -> T.TADag -> MatFun -> Bool -> ShowS+renderDebugOutput c dag matFun debug =+ ( if debug+ then dBegin . R.debugTransformResult c r . showChar '\n'+ else id+ )+ . begin+ . foldr (.) id (intersperse mid $ R.renderPretty c $ tqs ++ rqs)+ . end++ where -- SQL compliant separators. (comments)+ dBegin = showString "----- debug output: tile\n"+ begin = showString "----- graph output begin -->\n"+ end = showString "\n----- graph output end <--\n"+ mid = showString "\n----- additional query\n" + (r, (tqs, rqs))+ = resultFromDAG dag matFun++putShowSLn :: ShowS -> IO ()+putShowSLn s = putStrLn $ s ""++-- | Renders a DAG with the given renderer.+renderOutputWith :: (CompatMode -> [Query] -> [ShowS])+ -> CompatMode+ -> T.TADag+ -> MatFun+ -> ShowS+renderOutputWith renderer c dag matFun =+ foldr (.) id $ intersperse (showChar '\n') renderedQs+ where (_, (tqs, rqs)) = resultFromDAG dag matFun+ renderedQs = renderer c $ tqs ++ rqs++renderOutputCompact :: CompatMode -> T.TADag -> MatFun -> ShowS+renderOutputCompact = renderOutputWith R.renderCompact++renderOutputPlain :: CompatMode -> T.TADag -> MatFun -> ShowS+renderOutputPlain = renderOutputWith R.renderPlain++-- | Render output directly for DSH. The order from the root nodes in the+-- directed acyclic graph is preserved. (This function uses the combined+-- materialization strategy.)+renderOutputDSH :: CompatMode -> T.TADag -> (Maybe String, [String])+renderOutputDSH = flip renderOutputDSHWith C.materialize++-- | Render output directly for DSH. The order from the root nodes in the+-- directed acyclic graph is preserved.+renderOutputDSHWith :: CompatMode -> MatFun -> T.TADag -> (Maybe String, [String])+renderOutputDSHWith c matFun dag =+ ( if null preludeString+ then Nothing+ else Just preludeString+ , map ($ "") renderedRQs+ )+ where+ preludeString = foldr (.) id renderedTQs ""+ (_, (tqs, rqs)) = resultFromDAG dag matFun+ renderedRQs = R.renderCompact c rqs+ renderedTQs = R.renderCompact c tqs++-- | Produces output which allows further inspection with the psql command line+-- utility (and possibly others too).+renderAdvancedDebugOutput :: CompatMode -> Bool -> Bool -> T.TADag -> MatFun -> String+renderAdvancedDebugOutput c explain analyze dag matFun =+ foldr ((.) . (prefixes .)) id (renderedTQs ++ renderedRQs) ""+ where+ (_, (tqs, rqs)) = resultFromDAG dag matFun+ renderedRQs = R.renderPlain c rqs+ renderedTQs = R.renderPlain c tqs+ prefixes = showString $ ep ++ ap+ ep = if explain then "EXPLAIN " else ""+ ap = if analyze then "ANALYZE " else ""
+ src/Database/Algebra/Table/Construct.hs view
@@ -0,0 +1,225 @@+-- | This module contains smart constructors for table algebra plans.+module Database.Algebra.Table.Construct+ ( -- * Value and type constructors+ int, string, bool, double, dec, nat+ , intT, stringT, boolT, decT, doubleT, natT+ -- * Smart constructors for algebraic operators+ , dbTable, litTable, litTable', eqJoin, thetaJoin+ , semiJoin, antiJoin, rank, difference, rowrank+ , select, distinct, cross, union, proj, aggr, winFun+ , rownum, rownum'+ -- * Lifted smart constructors for table algebra operators+ , thetaJoinM, semiJoinM, antiJoinM, eqJoinM, rankM, differenceM+ , rowrankM, selectM, distinctM, crossM, unionM, projM+ , aggrM, winFunM, rownumM, rownum'M+ ) where++import Database.Algebra.Dag.Build+import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang++--------------------------------------------------------------------------------+-- Value constructors++-- | Create a TA int value+int :: Integer -> AVal+int = VInt++-- | Create a TA string value+string :: String -> AVal+string = VStr++-- | Create a TA boolean value+bool :: Bool -> AVal+bool = VBool++-- | Create a TA double value+double :: Double -> AVal+double = VDouble++-- | Create a TA decimal value+dec :: Float -> AVal+dec = VDec++-- | Create a TA nat value+nat :: Integer -> AVal+nat = VNat++-- | Types of atomic values+intT, stringT, boolT, decT, doubleT, natT :: ATy+intT = AInt+stringT = AStr+boolT = ABool+decT = ADec+doubleT = ADouble+natT = ANat++--------------------------------------------------------------------------------+-- Smart constructors for algebraic operators++-- | Construct a database table node+-- The first argument is the \emph{qualified} name of the database+-- table. The second describes the columns in alphabetical order.+-- The third argument describes the database keys (one table key can+-- span over multiple columns).+dbTable :: String -> [(Attr, ATy)] -> [Key] -> Build TableAlgebra AlgNode+dbTable n cs ks = insert $ NullaryOp $ TableRef (n, cs, ks)++-- | Construct a table with one value+litTable :: AVal -> String -> ATy -> Build TableAlgebra AlgNode+litTable v s t = insert $ NullaryOp $ LitTable ([[v]], [(s, t)])++-- | Construct a literal table with multiple columns and rows+litTable' :: [[AVal]] -> [(String, ATy)] -> Build TableAlgebra AlgNode+litTable' v s = insert $ NullaryOp $ LitTable (v, s)++-- | Join two plans where the columns n1 of table 1 and columns n2 of table+-- 2 are equal.+eqJoin :: LeftAttr -> RightAttr -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode+eqJoin n1 n2 c1 c2 = insert $ BinOp (EqJoin (n1, n2)) c1 c2++thetaJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode+thetaJoin cond c1 c2 = insert $ BinOp (ThetaJoin cond) c1 c2++semiJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode+semiJoin cond c1 c2 = insert $ BinOp (SemiJoin cond) c1 c2++antiJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode+antiJoin cond c1 c2 = insert $ BinOp (AntiJoin cond) c1 c2++-- | Assign a number to each row in column 'ResAttr' incrementally+-- sorted by `sort'. The numbering is not dense!+rank :: ResAttr -> [SortSpec] -> AlgNode -> Build TableAlgebra AlgNode+rank res sort c1 = insert $ UnOp (Rank (res, sort)) c1++-- | Compute the difference between two plans.+difference :: AlgNode -> AlgNode -> Build TableAlgebra AlgNode+difference q1 q2 = insert $ BinOp (Difference ()) q1 q2++-- | Same as rank but provides a dense numbering.+rowrank :: ResAttr -> [SortSpec] -> AlgNode -> Build TableAlgebra AlgNode+rowrank res sort c1 = insert $ UnOp (RowRank (res, sort)) c1++-- | Select rows where the column `SelAttr' contains True.+select :: Expr -> AlgNode -> Build TableAlgebra AlgNode+select sel c1 = insert $ UnOp (Select sel) c1++-- | Remove duplicate rows+distinct :: AlgNode -> Build TableAlgebra AlgNode+distinct c1 = insert $ UnOp (Distinct ()) c1++-- | Make cross product from two plans+cross :: AlgNode -> AlgNode -> Build TableAlgebra AlgNode+cross c1 c2 = insert $ BinOp (Cross ()) c1 c2++-- | Union between two plans+union :: AlgNode -> AlgNode -> Build TableAlgebra AlgNode+union c1 c2 = insert $ BinOp (DisjUnion ()) c1 c2++-- | Project/rename certain column out of a plan+proj :: [Proj] -> AlgNode -> Build TableAlgebra AlgNode+proj ps c = insert $ UnOp (Project ps) c++-- | Apply aggregate functions to a plan+aggr :: [(AggrType, ResAttr)] -> [(Attr, Expr)] -> AlgNode -> Build TableAlgebra AlgNode+aggr aggrs part c1 = insert $ UnOp (Aggr (aggrs, part)) c1++winFun :: (ResAttr, WinFun) + -> [PartExpr] + -> [SortSpec] + -> Maybe FrameBounds+ -> AlgNode + -> Build TableAlgebra AlgNode+winFun fun part sort frame c = insert $ UnOp (WinFun (fun, part, sort, frame)) c++-- | Similar to rowrank but this will assign a unique number to every+-- row (even if two rows are equal)+rownum :: Attr -> [Attr] -> [PartExpr] -> AlgNode -> Build TableAlgebra AlgNode+rownum res sort part c1 = insert $ UnOp (RowNum (res, map (\c -> (ColE c, Asc)) sort, part)) c1++-- | Same as rownum but columns can be assigned an ordering direction+rownum' :: Attr -> [SortSpec] -> [PartExpr] -> AlgNode -> Build TableAlgebra AlgNode+rownum' res sort part c1 = insert $ UnOp (RowNum (res, sort, part)) c1++--------------------------------------------------------------------------------+-- Lifted smart constructors for table algebra operators++bind1 :: Monad m => (a -> m b) -> m a -> m b+bind1 = (=<<)++bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+bind2 f a b = do+ a' <- a+ b' <- b+ f a' b'++-- | Perform theta join on two plans+thetaJoinM :: [(Expr, Expr, JoinRel)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+thetaJoinM cond = bind2 (thetaJoin cond)++-- | Perform a semi join on two plans+semiJoinM :: [(Expr, Expr, JoinRel)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+semiJoinM cond = bind2 (semiJoin cond)++-- | Perform an anti join on two plans+antiJoinM :: [(Expr, Expr, JoinRel)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+antiJoinM cond = bind2 (antiJoin cond)++-- | Join two plans where the columns n1 of table 1 and columns n2 of table+-- 2 are equal.+eqJoinM :: String -> String -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+eqJoinM n1 n2 = bind2 (eqJoin n1 n2)++-- | Assign a number to each row in column 'ResAttr' incrementing+-- sorted by `sort'. The numbering is not dense!+rankM :: ResAttr -> [SortSpec] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+rankM res sort = bind1 (rank res sort)++-- | Compute the difference between two plans.+differenceM :: Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+differenceM = bind2 difference++-- | Same as rank but provides a dense numbering.+rowrankM :: ResAttr -> [SortSpec] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+rowrankM res sort = bind1 (rowrank res sort)++-- | Select rows where the column `SelAttr' contains True.+selectM :: Expr -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+selectM sel = bind1 (select sel)++-- | Remove duplicate rows+distinctM :: Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+distinctM = bind1 distinct++-- | Make cross product from two plans+crossM :: Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+crossM = bind2 cross++-- | Union between two plans+unionM :: Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+unionM = bind2 union++-- | Project/rename certain column out of a plan+projM :: [Proj] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+projM cols = bind1 (proj cols)++-- | Apply aggregate functions to a plan+aggrM :: [(AggrType, ResAttr)] -> [(Attr, Expr)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+aggrM aggrs part = bind1 (aggr aggrs part)++winFunM :: (ResAttr, WinFun) + -> [PartExpr] + -> [SortSpec] + -> Maybe FrameBounds+ -> Build TableAlgebra AlgNode + -> Build TableAlgebra AlgNode+winFunM fun part sort frame = bind1 (winFun fun part sort frame)++-- | Similar to rowrank but this will assign a \emph{unique} number to every row+-- (even if two rows are equal)+rownumM :: Attr -> [Attr] -> [PartExpr] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+rownumM res sort part = bind1 (rownum res sort part)++-- | Same as rownum but columns can be assigned an ordering direction+rownum'M :: Attr -> [SortSpec] -> [PartExpr] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+rownum'M res sort part = bind1 (rownum' res sort part)
+ src/Database/Algebra/Table/Lang.hs view
@@ -0,0 +1,336 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | A representation of table algebra operators over multiset+-- relations.+module Database.Algebra.Table.Lang where++import Text.Printf+import Data.List+import Numeric (showFFloat)++import Database.Algebra.Dag (Operator, opChildren,+ replaceOpChild)+import Database.Algebra.Dag.Common++-- required for JSON+import GHC.Generics (Generic)++-- | Sorting rows in a direction+data SortDir = Asc+ | Desc+ deriving (Eq, Ord, Generic, Read)++data AggrType = Avg Expr+ | Max Expr+ | Min Expr+ | Sum Expr+ | Count+ | All Expr+ | Any Expr+ deriving (Eq, Ord, Generic)++instance Show AggrType where+ show (Avg c) = printf "avg(%s)" (show c)+ show (Max c) = printf "max(%s)" (show c)+ show (Min c) = printf "min(%s)" (show c)+ show (Sum c) = printf "sum(%s)" (show c)+ show Count = "count"+ show (All c) = printf "all(%s)" (show c)+ show (Any c) = printf "any(%s)" (show c)++-- | The show instance results in values that are accepted in the xml plan.+instance Show SortDir where+ show Asc = "ascending"+ show Desc = "descending"++-- | table algebra types+-- At this level we do not have any structural types anymore+-- those are represented by columns.+data ATy where+ AInt :: ATy+ AStr :: ATy+ ABool :: ATy+ ADec :: ATy+ ADouble :: ATy+ ANat :: ATy+ deriving (Eq, Ord, Generic)++-- | Show the table algebra types in a way that is compatible with+-- the xml plan.+instance Show ATy where+ show AInt = "int"+ show AStr = "str"+ show ABool = "bool"+ show ADec = "dec"+ show ADouble = "dbl"+ show ANat = "nat"++-- | Wrapper around values that can occur in an table algebra plan+data AVal where+ VInt :: Integer -> AVal+ VStr :: String -> AVal+ VBool :: Bool -> AVal+ VDouble :: Double -> AVal+ VDec :: Float -> AVal+ VNat :: Integer -> AVal+ deriving (Eq, Ord, Generic)++-- | Show the values in the way compatible with the xml plan.+instance Show AVal where+ show (VInt x) = show x+ show (VStr x) = x+ show (VBool True) = "true"+ show (VBool False) = "false"+ show (VDouble x) = show x+ show (VDec x) = showFFloat (Just 2) x ""+ show (VNat x) = show x++-- | Attribute name or column name+type Attr = String++-- | Name of an attribute in which the result of an expression,+-- aggregate or window function is stored.+type ResAttr = Attr++-- | Names of partition attributes used in window specifications+type PartAttr = Attr++-- | Left attribute name, used to represent the left argument when+-- applying binary operators+type LeftAttr = Attr++-- | Right attribute name, used to represent the right argument when+-- applying binary operators+type RightAttr = Attr+--+-- | Name of a database table+type TableName = String++-- | Typed columns+type TypedAttr = (Attr, ATy)++-- | Key of a database table, a key consists of multiple column names+newtype Key = Key [Attr] deriving (Eq, Ord, Show, Generic)++-- | Sorting information+type SortSpec = (Expr, SortDir)++-- | Binary functions and operators in expressions+data BinFun = Gt+ | Lt+ | GtE+ | LtE+ | Eq+ | NEq+ | And+ | Or+ | Plus+ | Minus+ | Times+ | Div+ | Modulo+ | Contains+ | SimilarTo+ | Like+ | Concat+ deriving (Eq, Ord, Generic)++instance Show BinFun where+ show Minus = "-"+ show Plus = "+"+ show Times = "*"+ show Div = "/"+ show Modulo = "%"+ show Contains = "fn:contains"+ show Concat = "fn:concat"+ show SimilarTo = "fn:similar_to"+ show Like = "fn:like"+ show Gt = ">"+ show Lt = "<"+ show GtE = ">="+ show LtE = "<="+ show Eq = "=="+ show NEq = "<>"+ show And = "&&"+ show Or = "||"++-- | Unary functions/operators in expressions+data UnFun = Not+ | Cast ATy+ | Sin+ | Cos+ | Tan+ | ASin+ | ACos+ | ATan+ | Sqrt+ | Log+ | Exp+ | SubString Integer Integer+ deriving (Eq, Ord, Generic)++instance Show UnFun where+ show Not = "not"+ show (Cast ty) = "cast->" ++ show ty+ show Sin = "sin"+ show Cos = "cos"+ show Tan = "tan"+ show Sqrt = "sqrt"+ show Exp = "exp"+ show Log = "log"+ show ASin = "asin"+ show ACos = "acos"+ show ATan = "atan"+ show (SubString f t) = printf "subString_%d,%d" f t++-- | Projection expressions+data Expr = BinAppE BinFun Expr Expr+ | UnAppE UnFun Expr+ | ColE Attr+ | ConstE AVal+ | IfE Expr Expr Expr+ deriving (Eq, Ord, Generic)++-- | Expressions which are used to specify partitioning in window+-- functions.+type PartExpr = Expr++instance Show Expr where+ show (BinAppE f e1 e2) = "(" ++ show e1 ++ ") " ++ show f ++ " (" ++ show e2 ++ ")"+ show (UnAppE f e) = show f ++ "(" ++ show e ++ ")"+ show (ColE c) = c+ show (ConstE v) = show v+ show (IfE c t e) = "if " ++ show c ++ " then " ++ show t ++ " else " ++ show e++-- | New column name and the expression that generates the new column+type Proj = (ResAttr, Expr)++-- | A tuple is a list of values+type Tuple = [AVal]++-- | Schema information, represents a table structure, the first element of the+-- tuple is the column name the second its type.+type SchemaInfos = [(Attr, ATy)]++-- | Comparison operators which can be used for ThetaJoins.+data JoinRel = EqJ -- equal+ | GtJ -- greater than+ | GeJ -- greater equal+ | LtJ -- less than+ | LeJ -- less equal+ | NeJ -- not equal+ deriving (Eq, Ord, Generic)++instance Show JoinRel where+ show EqJ = "eq"+ show GtJ = "gt"+ show GeJ = "ge"+ show LtJ = "lt"+ show LeJ = "le"+ show NeJ = "ne"++-- | Window frame start specification+data FrameStart = FSUnboundPrec -- ^ UNBOUNDED PRECEDING+ | FSValPrec Int -- ^ <value> PRECEDING+ | FSCurrRow -- ^ CURRENT ROW+ deriving (Eq, Ord, Show, Generic)++-- | Window frame end specification+data FrameEnd = FECurrRow -- ^ CURRENT ROW+ | FEValFol Int -- ^ <value> FOLLOWING+ | FEUnboundFol -- ^ UNBOUNDED FOLLOWING+ deriving (Eq, Ord, Show, Generic)++data FrameBounds = HalfOpenFrame FrameStart+ | ClosedFrame FrameStart FrameEnd + deriving (Eq, Ord, Show, Generic)++data WinFun = WinMax Expr+ | WinMin Expr+ | WinSum Expr+ | WinAvg Expr+ | WinAll Expr+ | WinAny Expr+ | WinFirstValue Expr+ | WinLastValue Expr+ | WinCount+ deriving (Eq, Ord, Show, Generic)+++data NullOp = LitTable ([Tuple], SchemaInfos)+ | TableRef (TableName, [TypedAttr], [Key])+ deriving (Ord, Eq, Show, Generic)++newtype DescrCol = DescrCol Attr deriving (Ord, Eq, Generic)++instance Show DescrCol where+ show (DescrCol c) = "Descr " ++ c++-- | Declare need for position columns in the query result. The+-- distinction between AbsPos and RelPos is only relevant for the+-- optimizer: AbsPos signals that the actual pos values are+-- required. RelPos signals that only the order induced by the pos+-- column is relevant.+data SerializeOrder = AbsPos Attr+ | RelPos [Attr]+ | NoPos+ deriving (Ord, Eq, Generic)++instance Show SerializeOrder where+ show (AbsPos c) = "AbsPos " ++ c+ show (RelPos cs) = "RelPos " ++ (intercalate ", " cs)+ show NoPos = "NoPos"++newtype PayloadCol = PayloadCol Attr deriving (Ord, Eq, Generic)++instance Show PayloadCol where+ show (PayloadCol c) = c++data UnOp = RowNum (Attr, [SortSpec], [PartExpr])+ | RowRank (ResAttr, [SortSpec])+ | WinFun ((ResAttr, WinFun), [PartExpr], [SortSpec], Maybe FrameBounds)+ | Rank (ResAttr, [SortSpec])+ | Project [(Attr, Expr)]+ | Select Expr+ | Distinct ()+ | Aggr ([(AggrType, ResAttr)], [(PartAttr, Expr)])++ -- Serialize must only occur as the root node of a+ -- query. It defines physical order of the query result:+ -- Vertically, the result is ordered by descr and pos+ -- columns. Columns must occur in the order defined by the+ -- list of payload column names.+ | Serialize (Maybe DescrCol, SerializeOrder, [PayloadCol])+ deriving (Ord, Eq, Show, Generic)++data BinOp = Cross ()+ | EqJoin (LeftAttr,RightAttr)+ | ThetaJoin [(Expr, Expr, JoinRel)]+ | SemiJoin [(Expr, Expr, JoinRel)]+ | AntiJoin [(Expr, Expr, JoinRel)]+ | DisjUnion ()+ | Difference ()+ deriving (Ord, Eq, Show, Generic)++type TableAlgebra = Algebra () BinOp UnOp NullOp AlgNode++replace :: Eq a => a -> a -> a -> a+replace orig new x = if x == orig then new else x++replaceChild :: forall t b u n c. Eq c => c -> c -> Algebra t b u n c -> Algebra t b u n c+replaceChild o n (TerOp op c1 c2 c3) = TerOp op (replace o n c1) (replace o n c2) (replace o n c3)+replaceChild o n (BinOp op c1 c2) = BinOp op (replace o n c1) (replace o n c2)+replaceChild o n (UnOp op c) = UnOp op (replace o n c)+replaceChild _ _ (NullaryOp op) = NullaryOp op++instance Operator TableAlgebra where+ opChildren (TerOp _ c1 c2 c3) = [c1, c2, c3]+ opChildren (BinOp _ c1 c2) = [c1, c2]+ opChildren (UnOp _ c) = [c]+ opChildren (NullaryOp _) = []++ replaceOpChild op old new = replaceChild old new op
+ src/Database/Algebra/Table/Render/Dot.hs view
@@ -0,0 +1,371 @@+module Database.Algebra.Table.Render.Dot(renderTADot) where++import qualified Data.IntMap as Map+import Data.List++import Text.PrettyPrint++import qualified Database.Algebra.Dag as Dag+import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang+++nodeToDoc :: AlgNode -> Doc+nodeToDoc n = (text "id:") <+> (int n)++tagsToDoc :: [Tag] -> Doc+tagsToDoc ts = vcat $ map text ts++labelToDoc :: AlgNode -> String -> Doc -> [Tag] -> Doc+labelToDoc n s as ts = (nodeToDoc n) <> text "\\n" <> ((text s) <> (parens as)) <> text "\\n" <> (tagsToDoc $ nub ts)++lookupTags :: AlgNode -> NodeMap [Tag] -> [Tag]+lookupTags n m = Map.findWithDefault [] n m++commas :: (a -> Doc) -> [a] -> Doc+commas f = hsep . punctuate comma . map f++renderProj :: Proj -> Doc+renderProj (new, ColE c) | new == c = text new+renderProj (new, e) = text $ concat [new, ":", show e]++renderAggr :: (AggrType, ResAttr) -> Doc+renderAggr (aggr, res) = text $ res ++ ":" ++ show aggr++renderSortInf :: SortSpec -> Doc+renderSortInf (ColE c, Desc) = text c <> text "/desc"+renderSortInf (expr, Desc) = (parens $ text (show expr)) <> text "/desc"+renderSortInf (ColE c, Asc) = text c+renderSortInf (expr, Asc) = parens $ text (show expr)++renderJoinArgs :: (Expr, Expr, JoinRel) -> Doc+renderJoinArgs (left, right, joinR) =+ (text $ show left) <+> (text $ show joinR) <+> (text $ show right)++renderPartExprs :: [PartExpr] -> Doc+renderPartExprs [] = empty+renderPartExprs es@(_:_) = text "/" <> commas (text . show) es++renderKey :: Key -> Doc+renderKey (Key k) = brackets $ commas text k++renderColumn :: (Attr, ATy) -> Doc+renderColumn (c, t) = text c <> text "::" <> (text $ show t)++renderTuple :: Tuple -> Doc+renderTuple = hcat . punctuate comma . map (text . show)++renderData :: [Tuple] -> Doc+renderData [] = empty+renderData xs = sep $ punctuate semi $ map renderTuple xs++renderTableInfo :: TableName -> [(Attr, ATy)] -> [Key] -> Doc+renderTableInfo tableName cols keys =+ (text tableName)+ <> text "\\n"+ <> (brackets $ commas renderColumn cols)+ <> text "\\n"+ <> (brackets $ commas renderKey keys)++opDotLabel :: NodeMap [Tag] -> AlgNode -> TALabel -> Doc+-- | Nullary operations+opDotLabel tags i (LitTableL dat _schema) = labelToDoc i+ "LITTABLE" (renderData dat) (lookupTags i tags)+opDotLabel tags i (TableRefL (name, attrs, keys)) = labelToDoc i+ "TABLE" (renderTableInfo name attrs keys) (lookupTags i tags)+-- | Binary operations+opDotLabel tags i (CrossL _) = labelToDoc i+ "CROSS" empty (lookupTags i tags)+opDotLabel tags i (EqJoinL (left,right)) = labelToDoc i+ "EQJOIN" (text $ left ++ "," ++ right) (lookupTags i tags)+opDotLabel tags i (DifferenceL _) = labelToDoc i+ "DIFF" empty (lookupTags i tags)+opDotLabel tags i (DisjUnionL _) = labelToDoc i+ "UNION" empty (lookupTags i tags)+opDotLabel tags i (ThetaJoinL info) = labelToDoc i+ "THETAJOIN" (commas renderJoinArgs info) (lookupTags i tags)+opDotLabel tags i (SemiJoinL info) = labelToDoc i+ "SEMIJOIN" (commas renderJoinArgs info) (lookupTags i tags)+opDotLabel tags i (AntiJoinL info) = labelToDoc i+ "ANTIJOIN" (commas renderJoinArgs info) (lookupTags i tags)+-- | Unary operations+opDotLabel tags i (RowNumL (res,sortI,attr)) = labelToDoc i+ "ROWNUM" ((text $ res ++ ":<")+ <> (commas renderSortInf sortI)+ <> text ">"+ <> renderPartExprs attr)+ (lookupTags i tags)+opDotLabel tags i (RowRankL (res,sortInf)) = labelToDoc i+ "ROWRANK" ((text $ res ++ ":<")+ <> (commas renderSortInf sortInf)+ <> text ">")+ (lookupTags i tags)+opDotLabel tags i (RankL (res,sortInf)) = labelToDoc i+ "RANK" ((text $ res ++ ":<")+ <> commas renderSortInf sortInf+ <> text ">")+ (lookupTags i tags)+opDotLabel tags i (ProjectL info) = labelToDoc i+ "PROJECT" (commas renderProj info) (lookupTags i tags)+opDotLabel tags i (SelL info) = labelToDoc i+ "SELECT" (text $ show info) (lookupTags i tags)+opDotLabel tags i (DistinctL _) = labelToDoc i+ "DISTINCT" empty (lookupTags i tags)+opDotLabel tags i (AggrL (aggrList, attr)) = labelToDoc i+ "AGGR" ((commas renderAggr aggrList) <+> (brackets $ commas renderProj attr))+ (lookupTags i tags)+opDotLabel tags i (SerializeL (mDescr, mPos, cols)) = labelToDoc i+ "SERIALIZE" (renderSerCol mDescr+ <+> (text $ show mPos)+ <+> (brackets $ commas (text . show) cols))+ (lookupTags i tags)+opDotLabel tags i (WinFunL (winFuns, partSpec, sortSpec, mFrameBounds)) = labelToDoc i+ "WIN" (hcat $ intersperse (text "\\n") [ renderWinFuns winFuns+ , renderPartSpec partSpec+ , renderSortSpec sortSpec+ , maybe empty renderFrameBounds mFrameBounds+ ])+ (lookupTags i tags)++renderWinFun :: WinFun -> Doc+renderWinFun (WinMax e) = text "MAX" <> (parens $ text $ show e)+renderWinFun (WinMin e) = text "MIN" <> (parens $ text $ show e)+renderWinFun (WinSum e) = text "SUM" <> (parens $ text $ show e)+renderWinFun (WinAvg e) = text "AVG" <> (parens $ text $ show e)+renderWinFun (WinAll e) = text "ALL" <> (parens $ text $ show e)+renderWinFun (WinAny e) = text "ANY" <> (parens $ text $ show e)+renderWinFun (WinFirstValue e) = text "first_value" <> (parens $ text $ show e)+renderWinFun (WinLastValue e) = text "last_value" <> (parens $ text $ show e)+renderWinFun WinCount = text "COUNT()"++renderWinFuns :: (ResAttr, WinFun) -> Doc+renderWinFuns (c, f) = renderWinFun f <+> text "AS" <+> text c++renderPartSpec :: [PartExpr] -> Doc+renderPartSpec [] = empty+renderPartSpec as@(_:_) = text "PARTITION BY" <+> commas (text . show) as++renderSortSpec :: [SortSpec] -> Doc+renderSortSpec [] = empty+renderSortSpec ss@(_:_) = text "ORDER BY" <+> commas renderSortInf ss++renderFrameBounds :: FrameBounds -> Doc+renderFrameBounds (HalfOpenFrame fs) = renderFrameStart fs+renderFrameBounds (ClosedFrame fs fe) = renderFrameStart fs + <+> text "AND" + <+> renderFrameEnd fe++renderFrameStart :: FrameStart -> Doc+renderFrameStart FSUnboundPrec = text "UNBOUNDED PRECEDING"+renderFrameStart (FSValPrec i) = int i <+> text "PRECEDING"+renderFrameStart FSCurrRow = text "CURRENT ROW"++renderFrameEnd :: FrameEnd -> Doc+renderFrameEnd FEUnboundFol = text "UNBOUNDED FOLLOWING"+renderFrameEnd (FEValFol i) = int i <+> text "FOLLOWING"+renderFrameEnd FECurrRow = text "CURRENT ROW"++renderSerCol :: Show c => Maybe c -> Doc+renderSerCol Nothing = empty+renderSerCol (Just c) = (text $ show c) <> comma++constructDotNode :: NodeMap [Tag] -> (AlgNode, TALabel) -> DotNode+constructDotNode tags (n, op) =+ DotNode n l c Nothing+ where l = render $ opDotLabel tags n op+ c = opDotColor op++-- | Create an abstract Dot edge+constructDotEdge :: (AlgNode, AlgNode) -> DotEdge+constructDotEdge = uncurry DotEdge++renderDotEdge :: DotEdge -> Doc+renderDotEdge (DotEdge u v) = int u <+> text "->" <+> int v <> semi++renderColor :: DotColor -> Doc+renderColor DCTomato = text "tomato"+renderColor DCRed = text "red"+renderColor DCOrangeDCRed = text "orangered"+renderColor DCSalmon = text "salmon"+renderColor DCGray = text "gray"+renderColor DCDimDCGray = text "dimgray"+renderColor DCGold = text "gold"+renderColor DCTan = text "tan"+renderColor DCCrimson = text "crimson"+renderColor DCGreen = text "green"+renderColor DCSienna = text "sienna"+renderColor DCBeige = text "beige"+renderColor DCDodgerBlue = text "dodgerblue"+renderColor DCLightSkyBlue = text "lightskyblue"+renderColor DCGray52 = text "gray52"+renderColor DCGray91 = text "gray91"+renderColor DCDarkDCOrange = text "darkorange"+renderColor DCOrange = text "orange"+renderColor DCWhite = text "white"+renderColor DCCyan = text "cyan"+renderColor DCCyan4 = text "cyan4"+renderColor DCHotPink = text "hotpink"++opDotColor :: TALabel -> DotColor++-- | Nullaryops+opDotColor (LitTableL _ _) = DCGray52+opDotColor (TableRefL _) = DCGray52++-- | Unops+opDotColor (ProjectL _) = DCGray91+opDotColor (SerializeL _) = DCHotPink++opDotColor (SelL _) = DCCyan++opDotColor (DistinctL _) = DCTan+opDotColor (AggrL _) = DCGold++opDotColor (RankL _) = DCTomato+opDotColor (RowNumL _) = DCRed+opDotColor (RowRankL _) = DCRed+opDotColor (WinFunL _) = DCSalmon++-- | Binops+opDotColor (CrossL _) = DCOrangeDCRed++opDotColor (DifferenceL _) = DCDarkDCOrange+opDotColor (DisjUnionL _) = DCOrange++opDotColor (EqJoinL _) = DCGreen++opDotColor (ThetaJoinL _) = DCDodgerBlue+opDotColor (SemiJoinL _) = DCLightSkyBlue+opDotColor (AntiJoinL _) = DCLightSkyBlue++renderDotNode :: DotNode -> Doc+renderDotNode (DotNode n l c s) =+ int n+ <+> (brackets $ (((text "label=") <> (doubleQuotes $ text l))+ <> comma+ <+> (text "color=") <> (renderColor c)+ <> styleDoc))+ <> semi+ where styleDoc =+ case s of+ Just Solid -> comma <+> text "solid"+ Nothing -> empty++preamble :: Doc+preamble = graphAttributes $$ nodeAttributes+ where nodeAttributes = text "node" <+> (brackets $ text "style=filled" <> comma <+> text "shape=box") <> semi+ graphAttributes = text "ordering=out;"++-- | Dot colors+data DotColor = DCTomato+ | DCSalmon+ | DCGray+ | DCDimDCGray+ | DCGold+ | DCTan+ | DCRed+ | DCOrangeDCRed+ | DCCrimson+ | DCGreen+ | DCSienna+ | DCBeige+ | DCDodgerBlue+ | DCLightSkyBlue+ | DCGray91+ | DCGray52+ | DCDarkDCOrange+ | DCOrange+ | DCCyan+ | DCCyan4+ | DCWhite+ | DCHotPink++-- Type of Dot style options+data DotStyle = Solid++-- label of Dot nodes+type DotLabel = String++-- id of Dot nodes+type DotNodeID = Int++-- Type of Dot nodes+data DotNode = DotNode DotNodeID DotLabel DotColor (Maybe DotStyle)++-- Type of Dot edges+data DotEdge = DotEdge DotNodeID DotNodeID++-- | Render a Dot document from the preamble, nodes and edges+renderDot :: [DotNode] -> [DotEdge] -> Doc+renderDot ns es = text "digraph" <> (braces $ preamble $$ nodeSection $$ edgeSection)+ where nodeSection = vcat $ map renderDotNode ns+ edgeSection = vcat $ map renderDotEdge es++-- | Labels (to collect all operations (nullary, unary,binary))+data TALabel = LitTableL [Tuple] SchemaInfos+ | TableRefL (TableName, [TypedAttr], [Key])+ | AggrL ([(AggrType, ResAttr)], [(PartAttr, Expr)])+ | WinFunL ((ResAttr, WinFun), [PartExpr], [SortSpec], Maybe FrameBounds)+ | DistinctL ()+ | ProjectL [Proj]+ | RankL (ResAttr, [SortSpec])+ | RowNumL (Attr, [SortSpec], [PartExpr])+ | RowRankL (ResAttr, [SortSpec])+ | SelL Expr+ | CrossL ()+ | DifferenceL ()+ | DisjUnionL ()+ | EqJoinL (LeftAttr,RightAttr)+ | ThetaJoinL [(Expr, Expr, JoinRel)]+ | SemiJoinL [(Expr, Expr, JoinRel)]+ | AntiJoinL [(Expr, Expr, JoinRel)]+ | SerializeL (Maybe DescrCol, SerializeOrder, [PayloadCol])++labelOfOp :: TableAlgebra -> TALabel+labelOfOp (Database.Algebra.Dag.Common.BinOp op _ _) = labelOfBinOp op+labelOfOp (Database.Algebra.Dag.Common.UnOp op _) = labelOfUnOp op+labelOfOp (Database.Algebra.Dag.Common.NullaryOp op) = labelOfNullaryOp op+labelOfOp (TerOp _ _ _ _) = error "no tertiary operations"++labelOfBinOp :: BinOp -> TALabel+labelOfBinOp (Cross info) = CrossL info+labelOfBinOp (Difference info) = DifferenceL info+labelOfBinOp (DisjUnion info) = DisjUnionL info+labelOfBinOp (EqJoin info) = EqJoinL info+labelOfBinOp (ThetaJoin info) = ThetaJoinL info+labelOfBinOp (SemiJoin info) = SemiJoinL info+labelOfBinOp (AntiJoin info) = AntiJoinL info++labelOfUnOp :: UnOp -> TALabel+labelOfUnOp (WinFun info) = WinFunL info+labelOfUnOp (Aggr info) = AggrL info+labelOfUnOp (Distinct info) = DistinctL info+labelOfUnOp (Project info) = ProjectL info+labelOfUnOp (Rank info) = RankL info+labelOfUnOp (RowNum info) = RowNumL info+labelOfUnOp (RowRank info) = RowRankL info+labelOfUnOp (Select info) = SelL info+labelOfUnOp (Serialize info) = SerializeL info++labelOfNullaryOp :: NullOp -> TALabel+labelOfNullaryOp (LitTable (tups, schema)) = LitTableL tups schema+labelOfNullaryOp (TableRef info) = TableRefL info++-- | extract the operator descriptions and list of edges from a DAG++extractGraphStructure :: Dag.Operator a => (a -> TALabel)+ -> Dag.AlgebraDag a+ -> ([(AlgNode, TALabel)], [(AlgNode, AlgNode)])+extractGraphStructure toLabel d = (labels, childs)+ where nodes = Dag.topsort d+ operators = zip nodes $ map (flip Dag.operator d) nodes+ labels = map (\(n, op) -> (n, toLabel op)) operators+ childs = concat $ map (\(n, op) -> zip (repeat n) (Dag.opChildren op)) operators++-- | Render an TableAlgebra plan into a dot file (GraphViz).+renderTADot :: NodeMap [Tag] -> [AlgNode] -> NodeMap TableAlgebra -> String+renderTADot ts roots m = render $ renderDot dotNodes dotEdges+ where (opLabels, edges) = extractGraphStructure labelOfOp d+ d = Dag.mkDag m roots+ dotNodes = map (constructDotNode ts) opLabels+ dotEdges = map constructDotEdge edges
+ src/Database/Algebra/Table/Render/JSON.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Database.Algebra.Table.Render.JSON+ ( serializePlan+ , deserializePlan+ , planToFile+ , planFromFile+ ) where++import Control.Monad+import GHC.Generics (Generic)++import Data.Aeson (FromJSON, ToJSON, decode, encode)+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.IntMap as M++import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang++instance ToJSON ATy where+instance ToJSON AVal where+instance ToJSON SortDir where+instance ToJSON JoinRel where+instance ToJSON SortSpec where+instance ToJSON AggrType where+instance ToJSON NullOp where+instance ToJSON WinFun where+instance ToJSON UnOp where+instance ToJSON BinOp where+instance ToJSON Expr where+instance ToJSON UnFun where+instance ToJSON BinFun where+instance ToJSON Key where+instance ToJSON DescrCol where+instance ToJSON SerializeOrder where+instance ToJSON PayloadCol where+instance ToJSON FrameBounds where+instance ToJSON FrameEnd where+instance ToJSON FrameStart where++instance FromJSON ATy where+instance FromJSON AVal where+instance FromJSON SortDir where+instance FromJSON JoinRel where+instance FromJSON SortSpec where+instance FromJSON AggrType where+instance FromJSON NullOp where+instance FromJSON WinFun where+instance FromJSON UnOp where+instance FromJSON BinOp where+instance FromJSON Expr where+instance FromJSON UnFun where+instance FromJSON BinFun where+instance FromJSON Key where+instance FromJSON DescrCol where+instance FromJSON SerializeOrder where+instance FromJSON PayloadCol where+instance FromJSON FrameBounds where+instance FromJSON FrameEnd where+instance FromJSON FrameStart where++instance ToJSON Plan where+instance FromJSON Plan where++data Plan = Plan { tags :: [(AlgNode, [Tag])], roots :: [AlgNode], graph :: [(AlgNode, TableAlgebra)] }+ deriving Generic++serializePlan :: (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra) -> BL.ByteString+serializePlan (ts, rs, g) = let tags' = M.toList ts+ graph' = M.toList g+ in encode $ Plan {tags = tags', roots = rs, graph = graph'}++deserializePlan :: BL.ByteString -> (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra)+deserializePlan s = let Just (Plan ts rs g) = decode s+ in (M.fromList ts, rs, M.fromList g)++planToFile :: FilePath -> (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra) -> IO ()+planToFile f t = BL.writeFile f $ serializePlan t++planFromFile :: FilePath -> IO (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra)+planFromFile f = liftM deserializePlan $ BL.readFile f
+ src/Database/Algebra/Table/Tools/DotGen.hs view
@@ -0,0 +1,61 @@+-- | Debugging utility for table algebra plans. Takes a plan from the command+-- line or standard input and renders it into a GraphViz file.+module Main where++import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++import Data.Maybe++import Data.ByteString.Lazy.Char8 (pack)++import Database.Algebra.Table.Render.Dot+import Database.Algebra.Table.Render.JSON++data Options = Options { optInput :: IO String+ , optRootNodes :: Maybe [Int]+ }++startOptions :: Options+startOptions = Options { optInput = getContents+ , optRootNodes = Nothing+ }++options :: [OptDescr (Options -> IO Options)]+options =+ [ Option "i" ["input"]+ (ReqArg (\arg opt -> return opt { optInput = readFile arg })+ "FILE")+ "Input file"+ , Option "n" ["rootnodes"]+ (ReqArg (\arg opt -> return opt { optRootNodes = Just $ read arg })+ "ROOTNODES")+ "List of root nodes to use (must be in Haskell list syntax)"+ , Option "h" ["help"]+ (NoArg+ (\_ -> do+ prg <- getProgName+ hPutStrLn stderr (usageInfo prg options)+ exitWith ExitSuccess))+ "Show help"+ ]++main :: IO ()+main = do+ args <- getArgs+ let (actions, _, _) = getOpt RequireOrder options args+ opts <- foldl (>>=) (return startOptions) actions+ let Options { optInput = input+ , optRootNodes = mRootNodes+ } = opts++ plan <- input++ let (tags, rs, m) = deserializePlan $ pack plan+ rs' = fromMaybe rs mRootNodes ++ let dot = renderTADot tags rs' m++ putStr dot