diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/algebra-sql.cabal b/algebra-sql.cabal new file mode 100644 --- /dev/null +++ b/algebra-sql.cabal @@ -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 + () over these operators + can be compiled into compact SQL:2003 queries. +License: BSD3 +License-file: LICENSE +Author: Alexander Ulrich, Moritz Bruder +Maintainer: +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 diff --git a/src/Database/Algebra/Impossible.hs b/src/Database/Algebra/Impossible.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Impossible.hs @@ -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))) diff --git a/src/Database/Algebra/SQL/Compatibility.hs b/src/Database/Algebra/SQL/Compatibility.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Compatibility.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Materialization.hs b/src/Database/Algebra/SQL/Materialization.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization.hs @@ -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])) + + + diff --git a/src/Database/Algebra/SQL/Materialization/CTE.hs b/src/Database/Algebra/SQL/Materialization/CTE.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization/CTE.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Materialization/Combined.hs b/src/Database/Algebra/SQL/Materialization/Combined.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization/Combined.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Materialization/Graph.hs b/src/Database/Algebra/SQL/Materialization/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization/Graph.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Materialization/TemporaryTable.hs b/src/Database/Algebra/SQL/Materialization/TemporaryTable.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization/TemporaryTable.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Materialization/Util.hs b/src/Database/Algebra/SQL/Materialization/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Materialization/Util.hs @@ -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) + + diff --git a/src/Database/Algebra/SQL/Query.hs b/src/Database/Algebra/SQL/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Query.hs @@ -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 -- ^ PRECEDING + | FSCurrRow -- ^ CURRENT ROW + deriving (Show) + +-- | Window frame end specification +data FrameEnd = FECurrRow -- ^ CURRENT ROW + | FEValFol Int -- ^ 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 + diff --git a/src/Database/Algebra/SQL/Query/Substitution.hs b/src/Database/Algebra/SQL/Query/Substitution.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Query/Substitution.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Query/Util.hs b/src/Database/Algebra/SQL/Query/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Query/Util.hs @@ -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 = + diff --git a/src/Database/Algebra/SQL/Render.hs b/src/Database/Algebra/SQL/Render.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Render.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Render/Query.hs b/src/Database/Algebra/SQL/Render/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Render/Query.hs @@ -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" + diff --git a/src/Database/Algebra/SQL/Render/Tile.hs b/src/Database/Algebra/SQL/Render/Tile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Render/Tile.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Termination.hs b/src/Database/Algebra/SQL/Termination.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Termination.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Tile.hs b/src/Database/Algebra/SQL/Tile.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Tile.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Tile/Flatten.hs b/src/Database/Algebra/SQL/Tile/Flatten.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Tile/Flatten.hs @@ -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 + diff --git a/src/Database/Algebra/SQL/Tools/Gen.hs b/src/Database/Algebra/SQL/Tools/Gen.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Tools/Gen.hs @@ -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 "") + "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 }) "") + "Specify the type of materialization (defaults to cte):\n\ + \ lcte | cte | tmp | com | coml | comh" + , Option + "f" + ["fast"] + (OptArg handleFast "") + "Render a fast but ugly sql representation optional with formatting:\ + \ '' | 'f'" + , Option + "c" + ["compat"] + ( ReqArg (\s opt -> opt { optCompatMode = parseCompatMode s }) + "" + ) + "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 + diff --git a/src/Database/Algebra/SQL/Util.hs b/src/Database/Algebra/SQL/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/SQL/Util.hs @@ -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 "" diff --git a/src/Database/Algebra/Table/Construct.hs b/src/Database/Algebra/Table/Construct.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Table/Construct.hs @@ -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) diff --git a/src/Database/Algebra/Table/Lang.hs b/src/Database/Algebra/Table/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Table/Lang.hs @@ -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 -- ^ PRECEDING + | FSCurrRow -- ^ CURRENT ROW + deriving (Eq, Ord, Show, Generic) + +-- | Window frame end specification +data FrameEnd = FECurrRow -- ^ CURRENT ROW + | FEValFol Int -- ^ 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 diff --git a/src/Database/Algebra/Table/Render/Dot.hs b/src/Database/Algebra/Table/Render/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Table/Render/Dot.hs @@ -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 diff --git a/src/Database/Algebra/Table/Render/JSON.hs b/src/Database/Algebra/Table/Render/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Table/Render/JSON.hs @@ -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 diff --git a/src/Database/Algebra/Table/Tools/DotGen.hs b/src/Database/Algebra/Table/Tools/DotGen.hs new file mode 100644 --- /dev/null +++ b/src/Database/Algebra/Table/Tools/DotGen.hs @@ -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