algebra-sql 0.1.0.1 → 0.3.0.0
raw patch · 21 files changed
+910/−818 lines, 21 filesdep +Decimaldep +textdep +timedep ~ansi-wl-pprintdep ~basesetup-changed
Dependencies added: Decimal, text, time
Dependency ranges changed: ansi-wl-pprint, base
Files
- Setup.hs +1/−0
- algebra-sql.cabal +40/−27
- src/Database/Algebra/SQL/File.hs +8/−7
- src/Database/Algebra/SQL/Materialization.hs +1/−1
- src/Database/Algebra/SQL/Materialization/CTE.hs +4/−4
- src/Database/Algebra/SQL/Materialization/Combined.hs +9/−9
- src/Database/Algebra/SQL/Query.hs +64/−44
- src/Database/Algebra/SQL/Query/Substitution.hs +17/−14
- src/Database/Algebra/SQL/Query/Util.hs +1/−3
- src/Database/Algebra/SQL/Render/Query.hs +139/−112
- src/Database/Algebra/SQL/Render/Tile.hs +2/−1
- src/Database/Algebra/SQL/Termination.hs +4/−4
- src/Database/Algebra/SQL/Tile.hs +173/−126
- src/Database/Algebra/SQL/Tile/Flatten.hs +1/−1
- src/Database/Algebra/SQL/Tools/Gen.hs +3/−3
- src/Database/Algebra/SQL/Util.hs +3/−3
- src/Database/Algebra/Table/Construct.hs +27/−19
- src/Database/Algebra/Table/Lang.hs +182/−134
- src/Database/Algebra/Table/Render/Dot.hs +217/−210
- src/Database/Algebra/Table/Render/JSON.hs +0/−83
- src/Database/Algebra/Table/Tools/DotGen.hs +14/−13
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
algebra-sql.cabal view
@@ -2,7 +2,7 @@ Name: algebra-sql synopsis: Relational Algebra and SQL Code Generation Category: Database-Version: 0.1.0.1+Version: 0.3.0.0 Description: This library contains data types for relational table algebra operators. DAG plans (<http://hackage.haskell.org/package/algebra-dag algebra-dag>) over these operators can be compiled into compact SQL:2003 queries.@@ -14,27 +14,29 @@ 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, + build-depends: base >= 4.8 && < 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,+ ansi-wl-pprint >= 0.6.7.2, multiset >= 0.2, aeson >= 0.8,+ time >= 1.4, filepath >= 1.3, process >= 1.2,+ Decimal >= 0.4,+ text >= 1.2, algebra-dag >= 0.1 exposed-modules: Database.Algebra.Table.Render.Dot- Database.Algebra.Table.Render.JSON Database.Algebra.Table.Lang Database.Algebra.Table.Construct @@ -45,7 +47,7 @@ Database.Algebra.SQL.Materialization.Combined hs-source-dirs: src- GHC-Options: -Wall -fno-warn-orphans+ GHC-Options: -Wall -fno-warn-orphans -O2 -fprof-auto other-modules: Database.Algebra.SQL.Query Database.Algebra.SQL.Query.Substitution Database.Algebra.SQL.Query.Util@@ -65,38 +67,49 @@ 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, + build-depends: base >= 4.8 && < 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+ Decimal >= 0.4,+ time >= 1.4,+ text >= 1.2,+ algebra-dag >= 0.1,+ ansi-wl-pprint >= 0.6.7.2 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, + build-depends: base >= 4.8 && < 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, + transformers >= 0.3, parsec >= 3.1, ghc-prim >= 0.3, bytestring >= 0.10, errors >= 1.0, dlist >= 0.7,- ansi-wl-pprint >= 0.6,+ ansi-wl-pprint >= 0.6.7.2, multiset >= 0.2,+ Decimal >= 0.4, aeson >= 0.8,+ time >= 1.4,+ text >= 1.2, algebra-dag >= 0.1++source-repository head+ type: git+ location: https://github.com/ulricha/algebra-sql
src/Database/Algebra/SQL/File.hs view
@@ -3,24 +3,25 @@ module Database.Algebra.SQL.File where import Control.Monad.Error.Class-import qualified Data.IntMap as IntMap+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as BL+ import System.FilePath import System.Process -import qualified Database.Algebra.Dag as D+import qualified Database.Algebra.Dag as D import Database.Algebra.Table.Render.Dot-import qualified Database.Algebra.Table.Render.JSON as JSON -import qualified Database.Algebra.SQL.Tile as T+import qualified Database.Algebra.SQL.Tile as T readDagFromFile :: FilePath -> IO (Either String T.TADag) readDagFromFile filename = case takeExtension filename of ".plan" -> do -- FIXME This function is a mess, does an unchecked fromJust, which -- easily fails.- (_, rootNodes, nodeMap) <- JSON.planFromFile filename+ Just dag <- decode <$> BL.readFile filename - return $ return $ D.mkDag nodeMap rootNodes+ return $ return dag format -> return $ throwError $ "unkown file format '" ++ format ++ "'"@@ -29,7 +30,7 @@ outputDot filename dag = do writeFile filename result putStrLn $ "Writing dot file to '" ++ filename ++ "'"- where result = renderTADot IntMap.empty (D.rootNodes dag) (D.nodeMap dag)+ where result = renderTADot (D.rootNodes dag) (D.nodeMap dag) renderDot :: FilePath -> FilePath -> IO () renderDot dotPath pdfPath = do
src/Database/Algebra/SQL/Materialization.hs view
@@ -1,5 +1,5 @@ -- Provides a basic toolset for materialization functions.-module Database.Algebra.SQL.Materialization +module Database.Algebra.SQL.Materialization ( MatFun ) where
src/Database/Algebra/SQL/Materialization/CTE.hs view
@@ -63,14 +63,14 @@ 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 @@ -79,7 +79,7 @@ visit v = do alreadyBound <- hasBinding v- + if alreadyBound -- Binding already added. then return Nothing@@ -114,7 +114,7 @@ addBinding v select return Nothing- + addBinding :: G.Vertex -> SelectStmt -> Gather () addBinding v select = modify $ IntMap.insert v select
src/Database/Algebra/SQL/Materialization/Combined.hs view
@@ -79,7 +79,7 @@ v has no parents: spa(v) = {} - + spa(v) = {} => \forall u \in spa(v): u is in every path to v @@ -184,18 +184,18 @@ 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+traverseGraph :: Graph -- ^ The used graph.+ -> G.Vertex -- ^ The current vertex.+ -> SFinder ()+traverseGraph 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+ mapM_ (traverseGraph graph) $ G.children v graph where parents = G.parents v graph @@ -209,8 +209,8 @@ -> IntMap.IntMap [G.Vertex] findSPA graph rootVertices = -- Collect the results with the SFinder MonadState.- execState (mapM_ (traverse graph) rootVertices) IntMap.empty- + execState (mapM_ (traverseGraph 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
src/Database/Algebra/SQL/Query.hs view
@@ -1,11 +1,14 @@ module Database.Algebra.SQL.Query where +import Data.Decimal+import qualified Data.Text as T+import qualified Data.Time.Calendar as C -- 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+ { valueQuery :: ValueQuery } | QDefinitionQuery { definitionQuery :: DefinitionQuery@@ -31,15 +34,15 @@ } -- Literal tables (e.g. "VALUES (1, 2), (2, 4)"). | VQLiteral- { rows :: [[ColumnExpr]] -- ^ The values contained.+ { 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+ cBindings :: [(String, Maybe [String], ValueQuery)]+ , cBody :: ValueQuery } -- A binary set operation -- (e.g. "TABLE foo UNION ALL TABLE bar").@@ -66,7 +69,7 @@ , -- | Indicates whether duplicates are removed. distinct :: Bool , -- | The constituents of the from clause.- fromClause :: [FromPart] + fromClause :: [FromPart] , -- | A list of conjunctive column expression. whereClause :: [ColumnExpr] , -- | The values to group by.@@ -92,9 +95,9 @@ 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.+ { 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.@@ -103,25 +106,35 @@ 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.+ { subQuery :: ValueQuery -- ^ The sub query. } | -- A placeholder which is substituted later. FEVariable- { vIdentifier :: ReferenceType+ { vIdentifier :: ReferenceType } -- Reference to an existing table. | FETableReference { tableReferenceName :: String -- ^ The name of the table.- } deriving Show+ }+ -- Explicit join syntax+ | FEExplicitJoin+ { joinType :: JoinOperator+ , leftArg :: FromPart+ , rightArg :: FromPart+ }+ deriving Show - +data JoinOperator = LeftOuterJoin ColumnExpr+ 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.+ { sExpr :: ExtendedExpr -- ^ The value expression aliased.+ , sName :: String -- ^ The name of the alias. } | SCExpr ExtendedExpr deriving Show@@ -130,7 +143,7 @@ data ExtendedExpr = -- | Encapsulates the base cases. EEBase- { valueExpr :: ValueExprTemplate ExtendedExpr -- ^ The value expression.+ { valueExpr :: ValueExprTemplate ExtendedExpr -- ^ The value expression. } -- | @f() OVER (PARTITION BY p ORDER BY s framespec)@ | EEWinFun@@ -143,9 +156,9 @@ -- | Optional frame specification , frameSpec :: Maybe FrameSpec }- -- | Aggregate function expression. + -- | Aggregate function expression. | EEAggrExpr- { aggrExpr :: AggrExpr+ { aggrExpr :: AggrExpr } deriving Show -- | Shorthand for the value expression base part of 'ExtendedExpr'.@@ -217,47 +230,38 @@ data ValueExprTemplate rec = -- | Encapsulates a representation of a SQL value. VEValue- { value :: Value -- ^ The value contained.+ { value :: Value -- ^ The value contained. } -- | A column. | VEColumn- { cName :: String -- ^ The name of the column.+ { 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.+ , cPrefix :: Maybe String } -- | Application of a binary function. | VEBinApp- { binFun :: BinaryFunction -- ^ The applied function.- , firstExpr :: rec -- ^ The first operand.- , secondExpr :: rec -- ^ The second operand.+ { 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.+ { unFun :: UnaryFunction -- ^ The applied function+ , arg :: rec -- ^ The operand } -- | e.g. @EXISTS (VALUES (1))@ | VEExists- { existsQuery :: ValueQuery -- ^ The query to check on.+ { 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.+ { 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+ { condExpr :: rec+ , thenBranch :: rec+ , elseBranch :: rec } deriving Show -- FIXME merge VECast and VENot into UnaryFunction (maybe not possible) @@ -287,6 +291,7 @@ | BFNotEqual | BFAnd | BFOr+ | BFCoalesce deriving Show -- | Types of unary functions@@ -300,8 +305,19 @@ | UFExp | UFLog | UFSubString Integer Integer+ | UFExtract ExtractField+ | UFNot+ -- A type cast (e.g. @CAST(1 AS DOUBLE PRECISION)@).+ | UFCast DataType+ | UFIsNull deriving (Show) +-- | Fields that can be extracted from date/time types+data ExtractField = ExtractDay+ | ExtractMonth+ | ExtractYear+ 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@@@ -313,18 +329,22 @@ | DTText -- | @BOOLEAN@ | DTBoolean+ -- | @DATE@+ | DTDate 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. + -- | Numeric data type with fixed precision and scale (e.g. @1.4@)+ | VDecimal Decimal+ -- | A double precision floating point number. | VDoublePrecision Double -- | e.g. @'foo'@- | VText String+ | VText T.Text -- | e.g. @TRUE@, @FALSE@ (but not UNKOWN in this variant) | VBoolean Bool+ -- | Standard SQL dates (Gregorian calendar)+ | VDate C.Day -- | 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.)
src/Database/Algebra/SQL/Query/Substitution.hs view
@@ -57,13 +57,11 @@ -> 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)@@ -105,6 +103,11 @@ replaceReferencesFromExpr r (Q.FEVariable v) = r v +replaceReferencesFromExpr r (Q.FEExplicitJoin op leftArg rightArg) =+ Q.FEExplicitJoin op+ (replaceReferencesFromPart r leftArg)+ (replaceReferencesFromPart r rightArg)+ replaceReferencesFromExpr _ t = t replaceReferencesValueQuery :: SubstitutionFunction@@ -142,38 +145,38 @@ replaceReferencesWindowFunction :: SubstitutionFunction -> Q.WindowFunction -> Q.WindowFunction-replaceReferencesWindowFunction r (Q.WFMax a) = +replaceReferencesWindowFunction r (Q.WFMax a) = Q.WFMax (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFMin a) = +replaceReferencesWindowFunction r (Q.WFMin a) = Q.WFMin (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFSum a) = +replaceReferencesWindowFunction r (Q.WFSum a) = Q.WFSum (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFAvg a) = +replaceReferencesWindowFunction r (Q.WFAvg a) = Q.WFAvg (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFAll a) = +replaceReferencesWindowFunction r (Q.WFAll a) = Q.WFAll (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFAny a) = +replaceReferencesWindowFunction r (Q.WFAny a) = Q.WFAny (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFFirstValue a) = +replaceReferencesWindowFunction r (Q.WFFirstValue a) = Q.WFFirstValue (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction r (Q.WFLastValue a) = +replaceReferencesWindowFunction r (Q.WFLastValue a) = Q.WFLastValue (replaceReferencesColumnExpr r a) -replaceReferencesWindowFunction _ Q.WFCount = +replaceReferencesWindowFunction _ Q.WFCount = Q.WFCount -replaceReferencesWindowFunction _ Q.WFRank = +replaceReferencesWindowFunction _ Q.WFRank = Q.WFRank -replaceReferencesWindowFunction _ Q.WFDenseRank = +replaceReferencesWindowFunction _ Q.WFDenseRank = Q.WFDenseRank -replaceReferencesWindowFunction _ Q.WFRowNumber = +replaceReferencesWindowFunction _ Q.WFRowNumber = Q.WFRowNumber
src/Database/Algebra/SQL/Query/Util.hs view
@@ -38,10 +38,8 @@ -- 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@@ -77,4 +75,4 @@ -- | Search for references and try to merge a select stmt at that position. --deepMergeSelectStmt :: (Int -> (Bool, Q.SelectStmt)) -> Q.SelectStmt -> Q.SelectStmt --deepMergeSelectStmt lookupFun select =- +
src/Database/Algebra/SQL/Render/Query.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} -- This file determines the semantics of the 'Query' data structure and all of -- its sub structures.@@ -7,40 +8,21 @@ , 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 qualified Data.Text as T+import qualified Data.Time.Calendar as C+import Text.PrettyPrint.ANSI.Leijen (Doc, align, bold, char,+ comma, double, empty,+ fillSep, 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+import Database.Algebra.SQL.Compatibility+import Database.Algebra.SQL.Query+import Prelude hiding ((<$>)) enlist :: [Doc] -> Doc enlist = fillSep . punctuate comma@@ -84,7 +66,7 @@ <+> as <$> indentedQuery - -- Default implementation for SQL:1999 compliant DBMS. + -- Default implementation for SQL:1999 compliant DBMS. _ -> as <$> indentedQuery@@ -140,7 +122,7 @@ then kw "DISTINCT" <+> sC else sC )- + <> case fromClause stmt of [] -> empty fromParts ->@@ -166,7 +148,7 @@ <+> align ( renderGenericOrderByList renderOrderExpr compat order- ) + ) renderOrderExpr :: CompatMode -> OrderExpr -> Doc@@ -191,8 +173,8 @@ renderFrameSpec :: FrameSpec -> Doc renderFrameSpec (FHalfOpen fs) = kw "ROWS" <+> renderFrameStart fs renderFrameSpec (FClosed fs fe) = kw "ROWS BETWEEN"- <+> renderFrameStart fs - <+> kw "AND" + <+> renderFrameStart fs+ <+> kw "AND" <+> renderFrameEnd fe renderFrameStart :: FrameStart -> Doc@@ -233,20 +215,31 @@ 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+renderFromExpr compat (FESubQuery q) = renderSubQuery compat q+renderFromExpr _ (FEVariable v) = ondullblue $ int v+renderFromExpr _ (FETableReference n) = text n+renderFromExpr compat (FEExplicitJoin jop l r) = renderJoinOp compat jop l r +renderJoinOp :: CompatMode -> JoinOperator -> FromPart -> FromPart -> Doc+renderJoinOp compat (LeftOuterJoin e) l r = parens $+ renderFromPart compat l+ <$> kw "LEFT OUTER JOIN"+ <$> renderFromPart compat r+ <$> kw "ON" <+> renderColumnExpr compat e+ -- | 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+renderSelectColumn compat (SCAlias e@(EEBase (VEColumn n1 _)) n2)+ | n1 == n2 = renderExtendedExpr compat e+ | n1 /= n2 = renderExtendedExpr compat e <+> kw "AS" <+> text n2+renderSelectColumn compat (SCAlias expr name)+ = renderExtendedExpr compat expr <+> kw "AS" <+> text name+renderSelectColumn compat (SCExpr expr)+ = renderExtendedExpr compat expr renderExtendedExpr :: CompatMode -> ExtendedExpr -> Doc@@ -254,7 +247,7 @@ renderExtendedExpr compat (EEWinFun wfun partExprs order mFrameSpec) = renderWindowFunction compat wfun <+> kw "OVER"- <+> parens (partitionByDoc <> orderByDoc <> frameSpecDoc) + <+> parens (partitionByDoc <> orderByDoc <> frameSpecDoc) where partitionByDoc = case partExprs of@@ -266,7 +259,7 @@ orderByDoc = case order of [] -> empty _ -> renderWindowOrderByList compat order <> linebreak- + frameSpecDoc = maybe empty (\fs -> renderFrameSpec fs) mFrameSpec renderExtendedExpr compat (EEAggrExpr ae) =@@ -277,7 +270,7 @@ AEBase ve -> renderValueExprTemplate renderAggrExpr compat ve - AEAggregate optVE aggr -> + AEAggregate optVE aggr -> renderAggregateFunction compat aggr <> parens (maybe (char '*') (renderColumnExpr compat) optVE) @@ -287,23 +280,20 @@ -> ValueExprTemplate a -> Doc renderValueExprTemplate renderRec compat ve = case ve of- VEValue v -> renderValue v+ VEValue v -> renderValue compat 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 BFCoalesce a b -> kw "COALESCE"+ <> parens (renderRec compat a+ <> comma+ <+> renderRec compat b) 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)+ parens $ renderUnaryFunction renderRec compat f a - VENot a -> parens $ kw "NOT" <+> renderRec compat a VEExists q -> kw "EXISTS" <+> renderSubQuery compat q VEIn v q -> parens $ renderRec compat v@@ -317,47 +307,28 @@ <+> 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"+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@@ -374,13 +345,13 @@ 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" +renderWindowFunction PostgreSQL (WFAll a) = renderFunCall "bool_and" (renderColumnExpr PostgreSQL a)-renderWindowFunction SQL99 (WFAll a) = renderFunCall "EVERY" +renderWindowFunction SQL99 (WFAll a) = renderFunCall "EVERY" (renderColumnExpr SQL99 a)-renderWindowFunction PostgreSQL (WFAny a) = renderFunCall "bool_or" +renderWindowFunction PostgreSQL (WFAny a) = renderFunCall "bool_or" (renderColumnExpr PostgreSQL a)-renderWindowFunction SQL99 (WFAny a) = renderFunCall "SOME" +renderWindowFunction SQL99 (WFAny a) = renderFunCall "SOME" (renderColumnExpr SQL99 a) renderColumnExpr :: CompatMode -> ColumnExpr -> Doc@@ -405,36 +376,92 @@ renderBinaryFunction BFNotEqual = kw "<>" renderBinaryFunction BFAnd = kw "AND" renderBinaryFunction BFOr = kw "OR"+renderBinaryFunction BFCoalesce = kw "COALESCE" -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+renderRegularUnary :: String -> Doc -> Doc+renderRegularUnary f a = kw f <> parens a +renderSubString :: CompatMode -> Integer -> Integer -> Doc -> Doc+renderSubString compat from to ra =+ case compat of+ SQL99 -> kw "substring" <> parens (ra+ <+> text "from" <+> integer from+ <+> text "for" <+> integer to)+ PostgreSQL -> kw "substr" <> parens (hsep $ punctuate comma [ ra+ , integer from+ , integer to+ ])+ MonetDB -> kw "substring" <> parens (hsep $ punctuate comma [ ra+ , integer from+ , integer to+ ])++renderUnaryFunction :: (CompatMode -> a -> Doc)+ -> CompatMode+ -> UnaryFunction+ -> a+ -> Doc+renderUnaryFunction renderRec compat fun argExpr =+ case fun of+ UFSin -> renderRegularUnary "sin" ra+ UFCos -> renderRegularUnary "cos" ra+ UFTan -> renderRegularUnary "tan" ra+ UFLog -> renderRegularUnary "log" ra+ UFSqrt -> renderRegularUnary "sqrt" ra+ UFExp -> renderRegularUnary "exp" ra+ UFASin -> renderRegularUnary "asin" ra+ UFACos -> renderRegularUnary "acos" ra+ UFATan -> renderRegularUnary "atan" ra+ (UFExtract field) ->+ kw "EXTRACT" <> parens (renderExtractField field <+> kw "FROM" <+> ra)+ -- The substring combinator is rendered special+ UFSubString f t -> renderSubString compat f t ra+ UFCast ty -> kw "CAST"+ <> parens (ra <+> kw "AS" <+> renderDataType ty)+ UFNot -> parens $ kw "NOT" <+> ra+ UFIsNull -> parens ra <+> kw "IS NULL"++ where+ ra = renderRec compat argExpr++renderExtractField :: ExtractField -> Doc+renderExtractField ExtractDay = kw "day"+renderExtractField ExtractMonth = kw "month"+renderExtractField ExtractYear = kw "year"+ renderDataType :: DataType -> Doc renderDataType DTInteger = kw "INTEGER" renderDataType DTDecimal = kw "DECIMAL" renderDataType DTDoublePrecision = kw "DOUBLE PRECISION" renderDataType DTText = kw "TEXT"-renderDataType DTBoolean = kw "BOOLEAN" +renderDataType DTBoolean = kw "BOOLEAN"+renderDataType DTDate = kw "DATE" literal :: Doc -> Doc literal = bold -renderValue :: Value -> Doc-renderValue v = case v of+-- | Escape a string literal.+-- FIXME no idea if the PostgreSQL mode works for other systems.+escape :: CompatMode -> T.Text -> T.Text+escape _ t = escapePostgreSQL t++-- | With PostgreSQL, single quotes can be escaped by doubling them.+escapePostgreSQL :: T.Text -> T.Text+escapePostgreSQL t = T.concatMap f t+ where+ -- Filter out null ('\0') characters+ f '\0' = T.empty+ f '\'' = "''"+ f c = T.singleton c++renderValue :: CompatMode -> Value -> Doc+renderValue c v = case v of VInteger i -> literal $ integer i- VDecimal d -> literal $ float d+ VDecimal d -> literal $ text $ show d VDoublePrecision d -> literal $ double d- VText str -> literal $ squotes $ text str+ VText str -> literal $ squotes $ text $ T.unpack $ escape c str VBoolean b -> kw $ if b then "TRUE" else "FALSE"- VNull -> literal $ text "null"-+ VNull -> literal $ text "NULL"+ VDate d -> literal $ text "DATE"+ <+>+ (squotes $ text $ C.showGregorian d)
src/Database/Algebra/SQL/Render/Tile.hs view
@@ -3,11 +3,12 @@ ) where +import Prelude hiding ( (<$>) ) import Text.PrettyPrint.ANSI.Leijen ( (<$>) , (<+>) , (<>) , Doc- , align + , align , black , bold , empty
src/Database/Algebra/SQL/Termination.hs view
@@ -18,9 +18,9 @@ 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.+data Feature = ProjectionF -- ^ Projection of columns.+ | TableF -- ^ Physical or virtual table.+ | FilterF -- ^ Filtering of rows. | DupElimF | SortF | WindowFunctionF@@ -87,7 +87,7 @@ WindowFunctionF -> S.fromList [FilterF, DupElimF, WindowFunctionF, AggrAndGroupingF] -- Problematic cases:- -- + -- -- * Filtering: May change intermediate result set. -- -- * Aggregate functions can not be stacked.
src/Database/Algebra/SQL/Tile.hs view
@@ -21,6 +21,7 @@ import Control.Arrow (second) import Control.Monad.RWS.Strict import qualified Data.DList as DL (DList, singleton)+import qualified Data.List as L import qualified Data.IntMap as IntMap import Data.Maybe import GHC.Exts hiding (inline)@@ -192,7 +193,10 @@ -- 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.BinOp bop c0 c1) ->+ case bop of+ A.ThetaJoin _ -> (False, transformBinOp bop c0 c1)+ _ -> (True, transformBinOp bop c0 c1) (C.TerOp () _ _ _) -> $impossible multiRef <- asks $ isMultiReferenced n@@ -252,8 +256,8 @@ [] where schema = map fst typedSchema- castedNull ty = Q.CEBase $ Q.VECast (Q.CEBase $ Q.VEValue Q.VNull)- (translateATy ty)+ castedNull ty = Q.CEBase $ Q.VEUnApp (Q.UFCast $ translateATy ty)+ (Q.CEBase $ Q.VEValue Q.VNull) translateLit = Q.CEBase . Q.VEValue . translateAVal transformNullaryOp (A.TableRef (name, typedSchema, _)) = do@@ -293,69 +297,34 @@ Nothing transformUnOp :: A.UnOp -> C.AlgNode -> Transform TileTree-transformUnOp (A.Serialize (mDescr, pos, payloadCols)) c = do+transformUnOp (A.Serialize (ref, key, ord, items)) 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]+ 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 - inlineOrderBy col = if col `elem` boundNames- then Q.EEBase $ Q.VEColumn col Nothing- else inline col+ let sortExprs = [ Q.OE (Q.EEBase $ mkCol rc) Q.Ascending+ | A.RefCol rc _ <- ref+ ]+ +++ [ Q.OE (Q.EEBase $ mkCol oc)+ (translateSortDir d)+ | A.OrdCol (oc, d) _ <- ord+ ] - (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, [])+ projs = [ translateAlias (rc, e) | A.RefCol rc e <- ref ]+ ++ [ translateAlias (kc, e) | A.KeyCol kc e <- key ]+ ++ [ translateAlias (oc, e) | A.OrdCol (oc, _) e <- ord ]+ ++ [ translateAlias (pc, e) | A.PayloadCol pc e <- items] 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- }+ select { Q.selectClause = projs , Q.orderByClause = sortExprs } 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)@@ -387,7 +356,7 @@ 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@@ -406,7 +375,7 @@ transformUnOp (A.Select expr) c = do (ctor, select, children) <- transformTerminated' c filterF- + return $ ctor ( appendToWhere ( translateExprCE (Just $ Q.selectClause select) expr@@ -425,12 +394,12 @@ 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) = + aggrToEE (a, n) = Q.SCAlias ( let (fun, optExpr) = translateAggrType a in Q.EEAggrExpr $ Q.AEAggregate (liftM translateE optExpr)@@ -477,7 +446,7 @@ col@(Q.SCAlias _ name) -> ctor select { Q.selectClause = col : pruneCol name sClause } children- col@Q.SCExpr{} -> + col@Q.SCExpr{} -> ctor select { Q.selectClause = col : sClause } children @@ -500,6 +469,8 @@ -- Impose a canonical order on entries in the SELECT clauses to -- ensure that schemata of the set operator inputs match.++ -- FIXME 'Q.sName' is a partial function! let select0' = select0 { Q.selectClause = sortWith Q.sName $ Q.selectClause select0 } select1' = select1 { Q.selectClause = sortWith Q.sName $ Q.selectClause select1 } @@ -582,25 +553,58 @@ (childrenFeatures, select, children) <- transformBinCrossJoin c0 c1 let sClause = Q.selectClause select- conds = map f conditions- f = translateJoinCond sClause sClause+ conds = map (translateJoinCond sClause sClause) conditions return $ TileNode childrenFeatures (appendAllToWhere conds select) children +transformBinOp (A.LeftOuterJoin conditions) c0 c1 = do+ (_, select0, children0) <- transformTerminated c0 noneF+ (_, select1, children1) <- transformTerminated c1 noneF++ let q0 = Q.FESubQuery $ Q.VQSelect select0+ let q1 = Q.FESubQuery $ Q.VQSelect select1++ fpAlias0 <- freshAlias+ fpAlias1 <- freshAlias++ let schema0 = map Q.sName $ Q.selectClause select0+ let schema1 = map Q.sName $ Q.selectClause select1++ let fp0 = Q.FPAlias q0 fpAlias0 Nothing+ let fp1 = Q.FPAlias q1 fpAlias1 Nothing++ joinAlias <- freshAlias++ let joinCond = translateExplJoinConds fpAlias0 fpAlias1 conditions+ let joinOp = Q.LeftOuterJoin joinCond++ return $ TileNode (projectF <> tableF)+ emptySelectStmt+ { Q.selectClause =+ (columnsFromSchema joinAlias $ schema0 ++ schema1)+ +++ (columnsFromSchema fpAlias1 schema1)+ , Q.fromClause =+ [ Q.FPAlias (Q.FEExplicitJoin joinOp fp0 fp1)+ joinAlias+ (Just $ schema0 ++ schema1) ]+ }+ (children0 ++ children1)+ 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)+ transformExistsJoin cs c0 c1 (Q.CEBase . Q.VEUnApp Q.UFNot) 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+ -> C.AlgNode -> (Q.ColumnExpr -> Q.ColumnExpr) -> Transform TileTree transformExistsJoin conditions c0 c1 wrapFun = do@@ -614,7 +618,7 @@ (_, 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@@ -634,30 +638,30 @@ 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' = + rightSelect' = case rightSelect of- Q.VQSelect + Q.VQSelect (Q.SelectStmt- [Q.SCExpr (Q.EEBase (Q.VEColumn colName (Just tabName)))] - False + [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@@ -683,7 +687,7 @@ -> Transform (FeatureSet, Q.SelectStmt, TileChildren) transformTerminated n topFs = do tile <- transformNode n- + case tile of TileNode bottomFs body children | topFs `terminatesOver` bottomFs -> do@@ -797,23 +801,13 @@ 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@@ -904,63 +898,116 @@ 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)+ 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 e -> (Q.AFCount, Just e)+ A.CountStar -> (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 =+translateExprTempl :: (Maybe [Q.SelectColumn] -> A.Expr -> a)+ -> (Q.ValueExprTemplate a -> a)+ -> ([Q.SelectColumn] -> String -> a)+ -> Maybe String+ -> Maybe [Q.SelectColumn]+ -> A.Expr+ -> a+translateExprTempl rec wrap inline mPrefix 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+ wrap $ Q.VEUnApp (translateUnFun f) (rec optSelectClause e) A.ColE n -> case optSelectClause of Just s -> inline s n- Nothing -> wrap $ mkCol n+ Nothing -> wrap $ Q.VEColumn n mPrefix A.ConstE v -> wrap $ Q.VEValue $ translateAVal v translateExprCE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ColumnExpr-translateExprCE = translateExprValueExprTemplate translateExprCE Q.CEBase inlineCE+translateExprCE = translateExprTempl translateExprCE Q.CEBase inlineCE Nothing translateExprEE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ExtendedExpr-translateExprEE = translateExprValueExprTemplate translateExprEE Q.EEBase inlineEE+translateExprEE = translateExprTempl translateExprEE Q.EEBase inlineEE Nothing translateExprAE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.AggrExpr-translateExprAE = translateExprValueExprTemplate translateExprAE Q.AEBase inlineAE+translateExprAE = translateExprTempl translateExprAE Q.AEBase inlineAE Nothing +--------------------------------------------------------------------------------+-- Translation of join conditions for explicit join syntax.++-- | Translate an expression that occurs in the join condition of an+-- explicit join (e.g. LEFT OUTER JOIN). No expressions are inlined+-- and all column references are prefixed with the subquery alias of+-- the respective join argument.+translateJoinExpr :: String -> A.Expr -> Q.ColumnExpr+translateJoinExpr prefix expr =+ case expr of+ A.IfE c t e ->+ Q.CEBase $ Q.VECase (translateJoinExpr prefix c)+ (translateJoinExpr prefix t)+ (translateJoinExpr prefix e)++ A.BinAppE f e1 e2 ->+ Q.CEBase $ Q.VEBinApp (translateBinFun f)+ (translateJoinExpr prefix e1)+ (translateJoinExpr prefix e2)+ A.UnAppE f e ->+ Q.CEBase $ Q.VEUnApp (translateUnFun f) (translateJoinExpr prefix e)++ A.ColE n -> Q.CEBase (Q.VEColumn n (Just prefix) )+ A.ConstE v -> Q.CEBase $ Q.VEValue $ translateAVal v++translateExplJoinConds :: String+ -> String+ -> [(A.Expr, A.Expr, A.JoinRel)]+ -> Q.ColumnExpr+translateExplJoinConds leftPrefix rightPrefix (jc : jcs) =+ L.foldl' (\ae e -> Q.CEBase $ Q.VEBinApp Q.BFAnd ae e)+ (translateExplJoinCond leftPrefix rightPrefix jc)+ (map (translateExplJoinCond leftPrefix rightPrefix) jcs)+translateExplJoinConds _ _ [] =+ $impossible++translateExplJoinCond :: String+ -> String+ -> (A.Expr, A.Expr, A.JoinRel)+ -> Q.ColumnExpr+translateExplJoinCond leftPrefix rightPrefix (l, r, j) =+ Q.CEBase $ Q.VEBinApp (translateJoinRel j)+ (translateJoinExpr leftPrefix l)+ (translateJoinExpr rightPrefix r)++--------------------------------------------------------------------------------++translateUnFun :: A.UnFun -> Q.UnaryFunction+translateUnFun f = case f of+ A.Not -> Q.UFNot+ A.Cast t -> (Q.UFCast $ translateATy t)+ A.Sin -> Q.UFSin+ A.Cos -> Q.UFCos+ A.Tan -> Q.UFTan+ A.ASin -> Q.UFASin+ A.ACos -> Q.UFACos+ A.ATan -> Q.UFATan+ A.Sqrt -> Q.UFSqrt+ A.Log -> Q.UFLog+ A.Exp -> Q.UFExp+ A.SubString from to -> (Q.UFSubString from to)+ A.DateDay -> (Q.UFExtract Q.ExtractDay)+ A.DateYear -> (Q.UFExtract Q.ExtractYear)+ A.DateMonth -> (Q.UFExtract Q.ExtractMonth)+ A.IsNull -> Q.UFIsNull+ translateBinFun :: A.BinFun -> Q.BinaryFunction translateBinFun f = case f of A.Gt -> Q.BFGreaterThan@@ -980,6 +1027,7 @@ A.SimilarTo -> Q.BFSimilarTo A.Like -> Q.BFLike A.Concat -> Q.BFConcat+ A.Coalesce -> Q.BFCoalesce -- | Translate sort information into '[Q.WindowOrderExpr]', using the column -- function, which takes a 'String'.@@ -992,8 +1040,8 @@ -- | 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.+-- 'A.Expr' contained within the join condition are inlined with the+-- corresponding select clauses. translateJoinCond :: [Q.SelectColumn] -- ^ Left select clause. -> [Q.SelectColumn] -- ^ Right select clause. -> (A.Expr, A.Expr, A.JoinRel)@@ -1015,7 +1063,7 @@ A.VBool b -> Q.VBoolean b A.VDouble d -> Q.VDoublePrecision d A.VDec d -> Q.VDecimal d- A.VNat n -> Q.VInteger n+ A.VDate d -> Q.VDate d translateATy :: A.ATy -> Q.DataType translateATy t = case t of@@ -1024,5 +1072,4 @@ A.ABool -> Q.DTBoolean A.ADec -> Q.DTDecimal A.ADouble -> Q.DTDoublePrecision- A.ANat -> Q.DTInteger-+ A.ADate -> Q.DTDate
src/Database/Algebra/SQL/Tile/Flatten.hs view
@@ -90,7 +90,7 @@ flattenTileTreeWith materializer substituter (ReferenceLeaf tableId s) = ( emptySelectStmt { Q.selectClause = map f s- , Q.fromClause = + , Q.fromClause = [Q.FPAlias (substituter alias) aliasName $ Just s] } , MultiSet.singleton alias
src/Database/Algebra/SQL/Tools/Gen.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ module Main where import Control.Monad (forM_,@@ -260,7 +262,6 @@ singleTests = [ tLitTable , tEmptyTable , tTableRef- , tSerialize , tRowNum , tRowRank , tRank@@ -299,7 +300,6 @@ -- 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))@@ -317,7 +317,7 @@ tDistinct = singletonU $ A.Distinct () tAggr = singletonU- $ A.Aggr ([(A.Count, "count")], [("a", A.ColE "a")])+ $ A.Aggr ([(A.CountStar, "count")], [("a", A.ColE "a")]) -- binary operators singletonB op = singletonGraph $ C.BinOp op 0 1
src/Database/Algebra/SQL/Util.hs view
@@ -39,7 +39,7 @@ 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" + mid = showString "\n----- additional query\n" (r, (tqs, rqs)) = resultFromDAG dag matFun @@ -81,8 +81,8 @@ where preludeString = foldr (.) id renderedTQs "" (_, (tqs, rqs)) = resultFromDAG dag matFun- renderedRQs = R.renderCompact c rqs- renderedTQs = R.renderCompact c tqs+ renderedRQs = R.renderPlain c rqs+ renderedTQs = R.renderPlain c tqs -- | Produces output which allows further inspection with the psql command line -- utility (and possibly others too).
src/Database/Algebra/Table/Construct.hs view
@@ -1,19 +1,22 @@ -- | 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+ int, string, bool, double, dec, date+ , intT, stringT, boolT, decT, doubleT, dateT -- * Smart constructors for algebraic operators , dbTable, litTable, litTable', eqJoin, thetaJoin , semiJoin, antiJoin, rank, difference, rowrank , select, distinct, cross, union, proj, aggr, winFun- , rownum, rownum'+ , rownum, rownum', leftOuterJoin -- * Lifted smart constructors for table algebra operators , thetaJoinM, semiJoinM, antiJoinM, eqJoinM, rankM, differenceM , rowrankM, selectM, distinctM, crossM, unionM, projM- , aggrM, winFunM, rownumM, rownum'M+ , aggrM, winFunM, rownumM, rownum'M, leftOuterJoinM ) where +import Data.Decimal+import qualified Data.Text as T+import qualified Data.Time.Calendar as C import Database.Algebra.Dag.Build import Database.Algebra.Dag.Common import Database.Algebra.Table.Lang@@ -26,7 +29,7 @@ int = VInt -- | Create a TA string value-string :: String -> AVal+string :: T.Text -> AVal string = VStr -- | Create a TA boolean value@@ -38,21 +41,20 @@ double = VDouble -- | Create a TA decimal value-dec :: Float -> AVal+dec :: Decimal -> AVal dec = VDec --- | Create a TA nat value-nat :: Integer -> AVal-nat = VNat+date :: C.Day -> AVal+date = VDate -- | Types of atomic values-intT, stringT, boolT, decT, doubleT, natT :: ATy+intT, stringT, boolT, decT, doubleT, dateT :: ATy intT = AInt stringT = AStr boolT = ABool decT = ADec doubleT = ADouble-natT = ANat+dateT = ADate -------------------------------------------------------------------------------- -- Smart constructors for algebraic operators@@ -81,6 +83,9 @@ thetaJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode thetaJoin cond c1 c2 = insert $ BinOp (ThetaJoin cond) c1 c2 +leftOuterJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode+leftOuterJoin cond c1 c2 = insert $ BinOp (LeftOuterJoin cond) c1 c2+ semiJoin :: [(Expr, Expr, JoinRel)] -> AlgNode -> AlgNode -> Build TableAlgebra AlgNode semiJoin cond c1 c2 = insert $ BinOp (SemiJoin cond) c1 c2 @@ -124,11 +129,11 @@ aggr :: [(AggrType, ResAttr)] -> [(Attr, Expr)] -> AlgNode -> Build TableAlgebra AlgNode aggr aggrs part c1 = insert $ UnOp (Aggr (aggrs, part)) c1 -winFun :: (ResAttr, WinFun) - -> [PartExpr] - -> [SortSpec] +winFun :: (ResAttr, WinFun)+ -> [PartExpr]+ -> [SortSpec] -> Maybe FrameBounds- -> AlgNode + -> AlgNode -> Build TableAlgebra AlgNode winFun fun part sort frame c = insert $ UnOp (WinFun (fun, part, sort, frame)) c @@ -157,6 +162,9 @@ thetaJoinM :: [(Expr, Expr, JoinRel)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode thetaJoinM cond = bind2 (thetaJoin cond) +leftOuterJoinM :: [(Expr, Expr, JoinRel)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode+leftOuterJoinM cond = bind2 (leftOuterJoin 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)@@ -207,11 +215,11 @@ aggrM :: [(AggrType, ResAttr)] -> [(Attr, Expr)] -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode aggrM aggrs part = bind1 (aggr aggrs part) -winFunM :: (ResAttr, WinFun) - -> [PartExpr] - -> [SortSpec] +winFunM :: (ResAttr, WinFun)+ -> [PartExpr]+ -> [SortSpec] -> Maybe FrameBounds- -> Build TableAlgebra AlgNode + -> Build TableAlgebra AlgNode -> Build TableAlgebra AlgNode winFunM fun part sort frame = bind1 (winFun fun part sort frame)
src/Database/Algebra/Table/Lang.hs view
@@ -1,51 +1,56 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} -- | A representation of table algebra operators over multiset -- relations. module Database.Algebra.Table.Lang where +import Data.Aeson+import Data.Aeson.TH+import Data.Decimal+import Text.PrettyPrint.ANSI.Leijen ((<+>), (<>))+import qualified Text.PrettyPrint.ANSI.Leijen as P import Text.Printf-import Data.List-import Numeric (showFFloat) -import Database.Algebra.Dag (Operator, opChildren,- replaceOpChild)-import Database.Algebra.Dag.Common+import qualified Data.Text as T+import qualified Data.Time.Calendar as C --- required for JSON-import GHC.Generics (Generic)+import Database.Algebra.Dag (Operator, opChildren,+ replaceOpChild)+import Database.Algebra.Dag.Common -- | Sorting rows in a direction data SortDir = Asc | Desc- deriving (Eq, Ord, Generic, Read)+ deriving (Eq, Ord, Read, Show) data AggrType = Avg Expr | Max Expr | Min Expr | Sum Expr- | Count+ | CountStar+ | Count Expr | All Expr | Any Expr- deriving (Eq, Ord, Generic)+ deriving (Eq, Ord, Show) -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)+instance P.Pretty AggrType where+ pretty (Avg c) = P.text "avg" <> P.parens (P.pretty c)+ pretty (Max c) = P.text "max" <> P.parens (P.pretty c)+ pretty (Min c) = P.text "min" <> P.parens (P.pretty c)+ pretty (Sum c) = P.text "sum" <> P.parens (P.pretty c)+ pretty CountStar = P.text "count(*)"+ pretty (Count c) = P.text "count" <> P.parens (P.pretty c)+ pretty (All c) = P.text "all" <> P.parens (P.pretty c)+ pretty (Any c) = P.text "any" <> P.parens (P.pretty c) -- | The show instance results in values that are accepted in the xml plan.-instance Show SortDir where- show Asc = "ascending"- show Desc = "descending"+instance P.Pretty SortDir where+ pretty Asc = P.text "ascending"+ pretty Desc = P.text "descending" -- | table algebra types -- At this level we do not have any structural types anymore@@ -56,38 +61,38 @@ ABool :: ATy ADec :: ATy ADouble :: ATy- ANat :: ATy- deriving (Eq, Ord, Generic)+ ADate :: ATy+ deriving (Eq, Ord, Show) -- | 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"+instance P.Pretty ATy where+ pretty ADate = P.text "date"+ pretty AInt = P.text "int"+ pretty AStr = P.text "str"+ pretty ABool = P.text "bool"+ pretty ADec = P.text "dec"+ pretty ADouble = P.text "dbl" -- | 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)+ VInt :: Integer -> AVal+ VStr :: T.Text -> AVal+ VBool :: Bool -> AVal+ VDouble :: Double -> AVal+ VDec :: Decimal -> AVal+ VDate :: C.Day -> AVal+ deriving (Eq, Ord, Show) -- | 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+instance P.Pretty AVal where+ pretty (VInt x) = P.integer x+ pretty (VStr x) = P.text $ T.unpack x+ pretty (VBool True) = P.text "true"+ pretty (VBool False) = P.text "false"+ pretty (VDouble x) = P.double x+ pretty (VDec d) = P.text $ show d+ pretty (VDate d) = P.text $ C.showGregorian d -- | Attribute name or column name type Attr = String@@ -114,7 +119,7 @@ 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)+newtype Key = Key [Attr] deriving (Eq, Ord, Show) -- | Sorting information type SortSpec = (Expr, SortDir)@@ -137,26 +142,28 @@ | SimilarTo | Like | Concat- deriving (Eq, Ord, Generic)+ | Coalesce+ deriving (Eq, Ord, Show) -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 = "||"+instance P.Pretty BinFun where+ pretty Minus = P.text $ "-"+ pretty Plus = P.text $ "+"+ pretty Times = P.text $ "*"+ pretty Div = P.text $ "/"+ pretty Modulo = P.text $ "%"+ pretty Contains = P.text $ "fn:contains"+ pretty Concat = P.text $ "fn:concat"+ pretty SimilarTo = P.text $ "fn:similar_to"+ pretty Like = P.text $ "fn:like"+ pretty Gt = P.text $ ">"+ pretty Lt = P.text $ "<"+ pretty GtE = P.text $ ">="+ pretty LtE = P.text $ "<="+ pretty Eq = P.text $ "=="+ pretty NEq = P.text $ "<>"+ pretty And = P.text $ "&&"+ pretty Or = P.text $ "||"+ pretty Coalesce = P.text $ "coalesce" -- | Unary functions/operators in expressions data UnFun = Not@@ -170,22 +177,30 @@ | Sqrt | Log | Exp+ | DateDay+ | DateYear+ | DateMonth | SubString Integer Integer- deriving (Eq, Ord, Generic)+ | IsNull+ deriving (Eq, Ord, Show) -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+instance P.Pretty UnFun where+ pretty Not = P.text $ "not"+ pretty (Cast ty) = P.text "cast->" <> P.pretty ty+ pretty Sin = P.text $ "sin"+ pretty Cos = P.text $ "cos"+ pretty Tan = P.text $ "tan"+ pretty Sqrt = P.text $ "sqrt"+ pretty Exp = P.text $ "exp"+ pretty Log = P.text $ "log"+ pretty ASin = P.text $ "asin"+ pretty ACos = P.text $ "acos"+ pretty ATan = P.text $ "atan"+ pretty DateDay = P.text $ "date_day"+ pretty DateYear = P.text $ "date_year"+ pretty DateMonth = P.text $ "date_month"+ pretty IsNull = P.text $ "is_null"+ pretty (SubString f t) = P.text $ printf "subString_%d,%d" f t -- | Projection expressions data Expr = BinAppE BinFun Expr Expr@@ -193,29 +208,34 @@ | ColE Attr | ConstE AVal | IfE Expr Expr Expr- deriving (Eq, Ord, Generic)+ deriving (Eq, Ord, Show) -- | 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+parenthize :: Expr -> P.Doc+parenthize e =+ case e of+ ColE _ -> P.pretty e+ ConstE _ -> P.pretty e+ _ -> P.parens $ P.pretty e +instance P.Pretty Expr where+ pretty (BinAppE f e1 e2) = parenthize e1 <+> P.pretty f <+> parenthize e2+ pretty (UnAppE f e) = P.pretty f <+> (parenthize e)+ pretty (ColE c) = P.text c+ pretty (ConstE v) = P.pretty v+ pretty (IfE c t e) = P.text "if" <+> parenthize c+ <+> parenthize t+ <+> parenthize 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@@ -223,31 +243,31 @@ | LtJ -- less than | LeJ -- less equal | NeJ -- not equal- deriving (Eq, Ord, Generic)+ deriving (Eq, Ord, Show) -instance Show JoinRel where- show EqJ = "eq"- show GtJ = "gt"- show GeJ = "ge"- show LtJ = "lt"- show LeJ = "le"- show NeJ = "ne"+instance P.Pretty JoinRel where+ pretty EqJ = P.text "=="+ pretty GtJ = P.text ">"+ pretty GeJ = P.text ">="+ pretty LtJ = P.text "<"+ pretty LeJ = P.text "<="+ pretty NeJ = P.text "/=" -- | Window frame start specification data FrameStart = FSUnboundPrec -- ^ UNBOUNDED PRECEDING | FSValPrec Int -- ^ <value> PRECEDING | FSCurrRow -- ^ CURRENT ROW- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show) -- | Window frame end specification data FrameEnd = FECurrRow -- ^ CURRENT ROW | FEValFol Int -- ^ <value> FOLLOWING | FEUnboundFol -- ^ UNBOUNDED FOLLOWING- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show) data FrameBounds = HalfOpenFrame FrameStart- | ClosedFrame FrameStart FrameEnd - deriving (Eq, Ord, Show, Generic)+ | ClosedFrame FrameStart FrameEnd+ deriving (Eq, Ord, Show) data WinFun = WinMax Expr | WinMin Expr@@ -258,37 +278,30 @@ | WinFirstValue Expr | WinLastValue Expr | WinCount- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show) -data NullOp = LitTable ([Tuple], SchemaInfos)+data NullOp = LitTable ([Tuple], [TypedAttr]) | TableRef (TableName, [TypedAttr], [Key])- deriving (Ord, Eq, Show, Generic)--newtype DescrCol = DescrCol Attr deriving (Ord, Eq, Generic)+ deriving (Ord, Eq, Show) -instance Show DescrCol where- show (DescrCol c) = "Descr " ++ c+data PayloadCol = PayloadCol Attr Expr deriving (Ord, Eq, Show)+data OrdCol = OrdCol (Attr, SortDir) Expr deriving (Ord, Eq, Show)+data KeyCol = KeyCol Attr Expr deriving (Ord, Eq, Show)+data RefCol = RefCol Attr Expr deriving (Ord, Eq, Show) --- | 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 P.Pretty PayloadCol where+ pretty (PayloadCol c e) = P.text c <> P.colon <> P.pretty e -instance Show SerializeOrder where- show (AbsPos c) = "AbsPos " ++ c- show (RelPos cs) = "RelPos " ++ (intercalate ", " cs)- show NoPos = "NoPos"+instance P.Pretty OrdCol where+ pretty (OrdCol (c, Asc) e) = P.text c <> P.text ".asc:" <> P.pretty e+ pretty (OrdCol (c, Desc) e) = P.text c <> P.text ".desc:" <> P.pretty e -newtype PayloadCol = PayloadCol Attr deriving (Ord, Eq, Generic)+instance P.Pretty KeyCol where+ pretty (KeyCol c e) = P.text c <> P.text ":" <> P.pretty e -instance Show PayloadCol where- show (PayloadCol c) = c+instance P.Pretty RefCol where+ pretty (RefCol c e) = P.text c <> P.text ":" <> P.pretty e data UnOp = RowNum (Attr, [SortSpec], [PartExpr]) | RowRank (ResAttr, [SortSpec])@@ -299,22 +312,21 @@ | 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)+ -- Serialize must only occur as the root node of a query. It+ -- defines physical order, natural key and reference columns+ -- of the query result.+ | Serialize ([RefCol], [KeyCol], [OrdCol], [PayloadCol])+ deriving (Ord, Eq, Show) data BinOp = Cross () | EqJoin (LeftAttr,RightAttr) | ThetaJoin [(Expr, Expr, JoinRel)]+ | LeftOuterJoin [(Expr, Expr, JoinRel)] | SemiJoin [(Expr, Expr, JoinRel)] | AntiJoin [(Expr, Expr, JoinRel)] | DisjUnion () | Difference ()- deriving (Ord, Eq, Show, Generic)+ deriving (Ord, Eq, Show) type TableAlgebra = Algebra () BinOp UnOp NullOp AlgNode @@ -334,3 +346,39 @@ opChildren (NullaryOp _) = [] replaceOpChild op old new = replaceChild old new op++instance FromJSON C.Day where+ parseJSON o = (\(y, m, d) -> C.fromGregorian y m d) <$> parseJSON o++instance ToJSON C.Day where+ toJSON = toJSON . C.toGregorian++instance ToJSON Decimal where+ toJSON = toJSON . show++instance FromJSON Decimal where+ parseJSON s = read <$> parseJSON s++--------------------------------------------------------------------------------+-- Aeson instances for JSON serialization++deriveJSON defaultOptions ''AggrType+deriveJSON defaultOptions ''ATy+deriveJSON defaultOptions ''AVal+deriveJSON defaultOptions ''SortDir+deriveJSON defaultOptions ''JoinRel+deriveJSON defaultOptions ''NullOp+deriveJSON defaultOptions ''WinFun+deriveJSON defaultOptions ''UnOp+deriveJSON defaultOptions ''BinOp+deriveJSON defaultOptions ''Expr+deriveJSON defaultOptions ''UnFun+deriveJSON defaultOptions ''BinFun+deriveJSON defaultOptions ''Key+deriveJSON defaultOptions ''RefCol+deriveJSON defaultOptions ''KeyCol+deriveJSON defaultOptions ''OrdCol+deriveJSON defaultOptions ''PayloadCol+deriveJSON defaultOptions ''FrameBounds+deriveJSON defaultOptions ''FrameEnd+deriveJSON defaultOptions ''FrameStart
src/Database/Algebra/Table/Render/Dot.hs view
@@ -1,260 +1,264 @@ module Database.Algebra.Table.Render.Dot(renderTADot) where -import qualified Data.IntMap as Map+ import Data.List -import Text.PrettyPrint+import qualified Text.PrettyPrint.ANSI.Leijen as P -import qualified Database.Algebra.Dag as Dag+import qualified Database.Algebra.Dag as Dag import Database.Algebra.Dag.Common import Database.Algebra.Table.Lang +pp :: P.Pretty a => a -> String+pp a = (P.displayS $ P.renderPretty 0.9 120 $ P.pretty a) "" -nodeToDoc :: AlgNode -> Doc-nodeToDoc n = (text "id:") <+> (int n)+nodeToDoc :: AlgNode -> P.Doc+nodeToDoc n = (P.text "id:") P.<+> (P.int n) -tagsToDoc :: [Tag] -> Doc-tagsToDoc ts = vcat $ map text ts+labelToDoc :: AlgNode -> String -> P.Doc -> P.Doc+labelToDoc n s as = (nodeToDoc n) P.<+> P.text "\\n" P.<+> ((P.text s) P.<> (P.parens as)) -labelToDoc :: AlgNode -> String -> Doc -> [Tag] -> Doc-labelToDoc n s as ts = (nodeToDoc n) <> text "\\n" <> ((text s) <> (parens as)) <> text "\\n" <> (tagsToDoc $ nub ts)+commas :: (a -> P.Doc) -> [a] -> P.Doc+commas f = P.hsep . P.punctuate P.comma . map f -lookupTags :: AlgNode -> NodeMap [Tag] -> [Tag]-lookupTags n m = Map.findWithDefault [] n m+renderProj :: Proj -> P.Doc+renderProj (new, ColE c) | new == c = P.text new+renderProj (new, e) = P.text new P.<> P.colon P.<> P.pretty e -commas :: (a -> Doc) -> [a] -> Doc-commas f = hsep . punctuate comma . map f+renderAggr :: (AggrType, ResAttr) -> P.Doc+renderAggr (aggr, res) = P.text res P.<> P.colon P.<> P.pretty aggr -renderProj :: Proj -> Doc-renderProj (new, ColE c) | new == c = text new-renderProj (new, e) = text $ concat [new, ":", show e]+renderSortInf :: SortSpec -> P.Doc+renderSortInf (ColE c, Desc) = P.text c P.<+> P.text "/desc"+renderSortInf (expr, Desc) = (P.parens $ P.pretty expr) P.<> P.text "/desc"+renderSortInf (ColE c, Asc) = P.text c+renderSortInf (expr, Asc) = P.parens $ P.pretty expr -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 :: (Expr, Expr, JoinRel) -> P.Doc renderJoinArgs (left, right, joinR) =- (text $ show left) <+> (text $ show joinR) <+> (text $ show right)+ parenthize left P.<+> P.pretty joinR P.<+> parenthize right -renderPartExprs :: [PartExpr] -> Doc-renderPartExprs [] = empty-renderPartExprs es@(_:_) = text "/" <> commas (text . show) es+renderPartExprs :: [PartExpr] -> P.Doc+renderPartExprs [] = P.empty+renderPartExprs es@(_:_) = P.text "/" P.<+> commas P.pretty es -renderKey :: Key -> Doc-renderKey (Key k) = brackets $ commas text k+renderKey :: Key -> P.Doc+renderKey (Key k) = P.brackets $ commas P.text k -renderColumn :: (Attr, ATy) -> Doc-renderColumn (c, t) = text c <> text "::" <> (text $ show t)+renderColumn :: (Attr, ATy) -> P.Doc+renderColumn (c, t) = P.text c P.<+> P.text "::" P.<+> (P.pretty t) -renderTuple :: Tuple -> Doc-renderTuple = hcat . punctuate comma . map (text . show)+renderTuple :: Tuple -> P.Doc+renderTuple = P.hcat . P.punctuate P.comma . map P.pretty -renderData :: [Tuple] -> Doc-renderData [] = empty-renderData xs = sep $ punctuate semi $ map renderTuple xs+renderData :: [Tuple] -> P.Doc+renderData [] = P.empty+renderData xs = P.sep $ P.punctuate P.semi $ map renderTuple xs -renderTableInfo :: TableName -> [(Attr, ATy)] -> [Key] -> Doc+renderSchema :: [TypedAttr] -> P.Doc+renderSchema cols = commas renderColumn cols++renderTableInfo :: TableName -> [(Attr, ATy)] -> [Key] -> P.Doc renderTableInfo tableName cols keys =- (text tableName)- <> text "\\n"- <> (brackets $ commas renderColumn cols)- <> text "\\n"- <> (brackets $ commas renderKey keys)+ (P.text tableName)+ P.<+> P.text "\\n"+ P.<+> (P.brackets $ renderSchema cols)+ P.<+> P.text "\\n"+ P.<+> (P.brackets $ commas renderKey keys) -opDotLabel :: NodeMap [Tag] -> AlgNode -> TALabel -> Doc+opDotLabel :: AlgNode -> TALabel -> P.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)+opDotLabel i (LitTableL dat schema) = labelToDoc i+ "LITTABLE" (renderSchema schema P.<+> renderData dat)+opDotLabel i (TableRefL (name, attrs, keys)) = labelToDoc i+ "TABLE" (renderTableInfo name attrs keys) -- | 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)+opDotLabel i (CrossL _) = labelToDoc i+ "CROSS" P.empty+opDotLabel i (EqJoinL (left,right)) = labelToDoc i+ "EQJOIN" (P.text $ left ++ "," ++ right)+opDotLabel i (DifferenceL _) = labelToDoc i+ "DIFF" P.empty+opDotLabel i (DisjUnionL _) = labelToDoc i+ "UNION" P.empty+opDotLabel i (ThetaJoinL info) = labelToDoc i+ "THETAJOIN" (commas renderJoinArgs info)+opDotLabel i (LeftOuterJoinL info) = labelToDoc i+ "LEFTOUTERJOIN" (commas renderJoinArgs info)+opDotLabel i (SemiJoinL info) = labelToDoc i+ "SEMIJOIN" (commas renderJoinArgs info)+opDotLabel i (AntiJoinL info) = labelToDoc i+ "ANTIJOIN" (commas renderJoinArgs info) -- | 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)+opDotLabel i (RowNumL (res,sortI,attr)) = labelToDoc i+ "ROWNUM" ((P.text $ res ++ ":<")+ P.<+> (commas renderSortInf sortI)+ P.<+> P.text ">"+ P.<+> renderPartExprs attr)+opDotLabel i (RowRankL (res,sortInf)) = labelToDoc i+ "ROWRANK" ((P.text $ res ++ ":<")+ P.<+> (commas renderSortInf sortInf)+ P.<+> P.text ">")+opDotLabel i (RankL (res,sortInf)) = labelToDoc i+ "RANK" ((P.text $ res ++ ":<")+ P.<+> commas renderSortInf sortInf+ P.<+> P.text ">")+opDotLabel i (ProjectL info) = labelToDoc i+ "PROJECT" (commas renderProj info)+opDotLabel i (SelL info) = labelToDoc i+ "SELECT" (P.pretty info)+opDotLabel i (DistinctL _) = labelToDoc i+ "DISTINCT" P.empty+opDotLabel i (AggrL (aggrList, attr)) = labelToDoc i+ "AGGR" (commas renderAggr aggrList+ P.<+>+ (P.brackets $ commas renderProj attr))+opDotLabel i (SerializeL (ref, key, ord, item)) = labelToDoc i+ "SERIALIZE" (serializeArg "ref" ref P.<+> P.text "\n"+ P.<+> serializeArg "key" key P.<+> P.text "\n"+ P.<+> serializeArg "ord" ord P.<+> P.text "\n"+ P.<+> serializeArg "items" item P.<+> P.text "\n")+opDotLabel i (WinFunL (winFuns, partSpec, sortSpec, mFrameBounds)) = labelToDoc i+ "WIN" (P.hcat $ intersperse (P.text "\\n") [ renderWinFuns winFuns+ , renderPartSpec partSpec+ , renderSortSpec sortSpec+ , maybe P.empty+ renderFrameBounds+ mFrameBounds+ ]) -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()"+serializeArg :: P.Pretty a => String -> [a] -> P.Doc+serializeArg desc cols = P.text desc P.<+> P.equals+ P.<+> P.brackets (commas P.pretty cols) -renderWinFuns :: (ResAttr, WinFun) -> Doc-renderWinFuns (c, f) = renderWinFun f <+> text "AS" <+> text c+renderWinFun :: WinFun -> P.Doc+renderWinFun (WinMax e) = P.text "MAX" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinMin e) = P.text "MIN" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinSum e) = P.text "SUM" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinAvg e) = P.text "AVG" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinAll e) = P.text "ALL" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinAny e) = P.text "ANY" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinFirstValue e) = P.text "first_value" P.<+> (P.parens $ P.pretty e)+renderWinFun (WinLastValue e) = P.text "last_value" P.<+> (P.parens $ P.pretty e)+renderWinFun WinCount = P.text "COUNT()" -renderPartSpec :: [PartExpr] -> Doc-renderPartSpec [] = empty-renderPartSpec as@(_:_) = text "PARTITION BY" <+> commas (text . show) as+renderWinFuns :: (ResAttr, WinFun) -> P.Doc+renderWinFuns (c, f) = renderWinFun f P.<+> P.text "AS" P.<+> P.text c -renderSortSpec :: [SortSpec] -> Doc-renderSortSpec [] = empty-renderSortSpec ss@(_:_) = text "ORDER BY" <+> commas renderSortInf ss+renderPartSpec :: [PartExpr] -> P.Doc+renderPartSpec [] = P.empty+renderPartSpec as@(_:_) = P.text "PARTITION BY" P.<+> commas P.pretty as -renderFrameBounds :: FrameBounds -> Doc-renderFrameBounds (HalfOpenFrame fs) = renderFrameStart fs-renderFrameBounds (ClosedFrame fs fe) = renderFrameStart fs - <+> text "AND" - <+> renderFrameEnd fe+renderSortSpec :: [SortSpec] -> P.Doc+renderSortSpec [] = P.empty+renderSortSpec ss@(_:_) = P.text "ORDER BY" P.<+> commas renderSortInf ss -renderFrameStart :: FrameStart -> Doc-renderFrameStart FSUnboundPrec = text "UNBOUNDED PRECEDING"-renderFrameStart (FSValPrec i) = int i <+> text "PRECEDING"-renderFrameStart FSCurrRow = text "CURRENT ROW"+renderFrameBounds :: FrameBounds -> P.Doc+renderFrameBounds (HalfOpenFrame fs) = renderFrameStart fs+renderFrameBounds (ClosedFrame fs fe) = renderFrameStart fs+ P.<+> P.text "AND"+ P.<+> renderFrameEnd fe -renderFrameEnd :: FrameEnd -> Doc-renderFrameEnd FEUnboundFol = text "UNBOUNDED FOLLOWING"-renderFrameEnd (FEValFol i) = int i <+> text "FOLLOWING"-renderFrameEnd FECurrRow = text "CURRENT ROW"+renderFrameStart :: FrameStart -> P.Doc+renderFrameStart FSUnboundPrec = P.text "UNBOUNDED PRECEDING"+renderFrameStart (FSValPrec i) = P.int i P.<+> P.text "PRECEDING"+renderFrameStart FSCurrRow = P.text "CURRENT ROW" -renderSerCol :: Show c => Maybe c -> Doc-renderSerCol Nothing = empty-renderSerCol (Just c) = (text $ show c) <> comma+renderFrameEnd :: FrameEnd -> P.Doc+renderFrameEnd FEUnboundFol = P.text "UNBOUNDED FOLLOWING"+renderFrameEnd (FEValFol i) = P.int i P.<+> P.text "FOLLOWING"+renderFrameEnd FECurrRow = P.text "CURRENT ROW" -constructDotNode :: NodeMap [Tag] -> (AlgNode, TALabel) -> DotNode-constructDotNode tags (n, op) =+constructDotNode :: (AlgNode, TALabel) -> DotNode+constructDotNode (n, op) = DotNode n l c Nothing- where l = render $ opDotLabel tags n op+ where l = pp $ opDotLabel 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+renderDotEdge :: DotEdge -> P.Doc+renderDotEdge (DotEdge u v) = P.int u P.<+> P.text "->" P.<+> P.int v P.<+> P.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"+renderColor :: DotColor -> P.Doc+renderColor DCTomato = P.text "tomato"+renderColor DCRed = P.text "red"+renderColor DCOrangeDCRed = P.text "orangered"+renderColor DCSalmon = P.text "salmon"+renderColor DCGray = P.text "gray"+renderColor DCDimDCGray = P.text "dimgray"+renderColor DCGold = P.text "gold"+renderColor DCTan = P.text "tan"+renderColor DCCrimson = P.text "crimson"+renderColor DCGreen = P.text "green"+renderColor DCSienna = P.text "sienna"+renderColor DCBeige = P.text "beige"+renderColor DCDodgerBlue = P.text "dodgerblue"+renderColor DCLightSkyBlue = P.text "lightskyblue"+renderColor DCDeepSkyBlue = P.text "deepskyblue"+renderColor DCGray52 = P.text "gray52"+renderColor DCGray91 = P.text "gray91"+renderColor DCDarkDCOrange = P.text "darkorange"+renderColor DCOrange = P.text "orange"+renderColor DCWhite = P.text "white"+renderColor DCCyan = P.text "cyan"+renderColor DCCyan4 = P.text "cyan4"+renderColor DCHotPink = P.text "hotpink" opDotColor :: TALabel -> DotColor -- | Nullaryops-opDotColor (LitTableL _ _) = DCGray52-opDotColor (TableRefL _) = DCGray52+opDotColor (LitTableL _ _) = DCGray52+opDotColor (TableRefL _) = DCGray52 -- | Unops-opDotColor (ProjectL _) = DCGray91-opDotColor (SerializeL _) = DCHotPink+opDotColor (ProjectL _) = DCGray91+opDotColor (SerializeL _) = DCHotPink -opDotColor (SelL _) = DCCyan+opDotColor (SelL _) = DCCyan -opDotColor (DistinctL _) = DCTan-opDotColor (AggrL _) = DCGold+opDotColor (DistinctL _) = DCTan+opDotColor (AggrL _) = DCGold -opDotColor (RankL _) = DCTomato-opDotColor (RowNumL _) = DCRed-opDotColor (RowRankL _) = DCRed-opDotColor (WinFunL _) = DCSalmon+opDotColor (RankL _) = DCTomato+opDotColor (RowNumL _) = DCRed+opDotColor (RowRankL _) = DCRed+opDotColor (WinFunL _) = DCSalmon -- | Binops-opDotColor (CrossL _) = DCOrangeDCRed+opDotColor (CrossL _) = DCOrangeDCRed -opDotColor (DifferenceL _) = DCDarkDCOrange-opDotColor (DisjUnionL _) = DCOrange+opDotColor (DifferenceL _) = DCDarkDCOrange+opDotColor (DisjUnionL _) = DCOrange -opDotColor (EqJoinL _) = DCGreen+opDotColor (EqJoinL _) = DCGreen -opDotColor (ThetaJoinL _) = DCDodgerBlue-opDotColor (SemiJoinL _) = DCLightSkyBlue-opDotColor (AntiJoinL _) = DCLightSkyBlue+opDotColor (ThetaJoinL _) = DCDodgerBlue+opDotColor (LeftOuterJoinL _) = DCDeepSkyBlue+opDotColor (SemiJoinL _) = DCLightSkyBlue+opDotColor (AntiJoinL _) = DCLightSkyBlue -renderDotNode :: DotNode -> Doc+renderDotNode :: DotNode -> P.Doc renderDotNode (DotNode n l c s) =- int n- <+> (brackets $ (((text "label=") <> (doubleQuotes $ text l))- <> comma- <+> (text "color=") <> (renderColor c)- <> styleDoc))- <> semi+ P.int n+ P.<+> (P.brackets $ (((P.text "label=") P.<+> (P.dquotes $ P.text l))+ P.<+> P.comma+ P.<+> (P.text "color=") P.<+> (renderColor c)+ P.<+> styleDoc))+ P.<+> P.semi where styleDoc = case s of- Just Solid -> comma <+> text "solid"- Nothing -> empty+ Just Solid -> P.comma P.<+> P.text "solid"+ Nothing -> P.empty -preamble :: Doc-preamble = graphAttributes $$ nodeAttributes- where nodeAttributes = text "node" <+> (brackets $ text "style=filled" <> comma <+> text "shape=box") <> semi- graphAttributes = text "ordering=out;"+preamble :: P.Doc+preamble = graphAttributes P.</> nodeAttributes+ where+ nodeAttributes = P.text "node [style=filled, shape=box];"+ graphAttributes = P.text "ordering=out;" -- | Dot colors data DotColor = DCTomato@@ -271,6 +275,7 @@ | DCBeige | DCDodgerBlue | DCLightSkyBlue+ | DCDeepSkyBlue | DCGray91 | DCGray52 | DCDarkDCOrange@@ -296,13 +301,13 @@ 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+renderDot :: [DotNode] -> [DotEdge] -> P.Doc+renderDot ns es = P.text "digraph" P.<+> (P.braces $ preamble P.</> nodeSection P.</> edgeSection)+ where nodeSection = P.vcat $ map renderDotNode ns+ edgeSection = P.vcat $ map renderDotEdge es -- | Labels (to collect all operations (nullary, unary,binary))-data TALabel = LitTableL [Tuple] SchemaInfos+data TALabel = LitTableL [Tuple] [TypedAttr] | TableRefL (TableName, [TypedAttr], [Key]) | AggrL ([(AggrType, ResAttr)], [(PartAttr, Expr)]) | WinFunL ((ResAttr, WinFun), [PartExpr], [SortSpec], Maybe FrameBounds)@@ -319,7 +324,8 @@ | ThetaJoinL [(Expr, Expr, JoinRel)] | SemiJoinL [(Expr, Expr, JoinRel)] | AntiJoinL [(Expr, Expr, JoinRel)]- | SerializeL (Maybe DescrCol, SerializeOrder, [PayloadCol])+ | LeftOuterJoinL [(Expr, Expr, JoinRel)]+ | SerializeL ([RefCol], [KeyCol], [OrdCol], [PayloadCol]) labelOfOp :: TableAlgebra -> TALabel labelOfOp (Database.Algebra.Dag.Common.BinOp op _ _) = labelOfBinOp op@@ -328,13 +334,14 @@ 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+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+labelOfBinOp (LeftOuterJoin info) = LeftOuterJoinL info labelOfUnOp :: UnOp -> TALabel labelOfUnOp (WinFun info) = WinFunL info@@ -349,7 +356,7 @@ labelOfNullaryOp :: NullOp -> TALabel labelOfNullaryOp (LitTable (tups, schema)) = LitTableL tups schema-labelOfNullaryOp (TableRef info) = TableRefL info+labelOfNullaryOp (TableRef info) = TableRefL info -- | extract the operator descriptions and list of edges from a DAG @@ -363,9 +370,9 @@ 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+renderTADot :: [AlgNode] -> NodeMap TableAlgebra -> String+renderTADot roots m = pp $ renderDot dotNodes dotEdges where (opLabels, edges) = extractGraphStructure labelOfOp d d = Dag.mkDag m roots- dotNodes = map (constructDotNode ts) opLabels+ dotNodes = map constructDotNode opLabels dotEdges = map constructDotEdge edges
− src/Database/Algebra/Table/Render/JSON.hs
@@ -1,83 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Database.Algebra.Table.Render.JSON- ( serializePlan- , deserializePlan- , planToFile- , planFromFile- ) where--import Control.Monad-import GHC.Generics (Generic)--import Data.Aeson (FromJSON, ToJSON, decode, encode)-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.IntMap as M--import Database.Algebra.Dag.Common-import Database.Algebra.Table.Lang--instance ToJSON ATy where-instance ToJSON AVal where-instance ToJSON SortDir where-instance ToJSON JoinRel where-instance ToJSON SortSpec where-instance ToJSON AggrType where-instance ToJSON NullOp where-instance ToJSON WinFun where-instance ToJSON UnOp where-instance ToJSON BinOp where-instance ToJSON Expr where-instance ToJSON UnFun where-instance ToJSON BinFun where-instance ToJSON Key where-instance ToJSON DescrCol where-instance ToJSON SerializeOrder where-instance ToJSON PayloadCol where-instance ToJSON FrameBounds where-instance ToJSON FrameEnd where-instance ToJSON FrameStart where--instance FromJSON ATy where-instance FromJSON AVal where-instance FromJSON SortDir where-instance FromJSON JoinRel where-instance FromJSON SortSpec where-instance FromJSON AggrType where-instance FromJSON NullOp where-instance FromJSON WinFun where-instance FromJSON UnOp where-instance FromJSON BinOp where-instance FromJSON Expr where-instance FromJSON UnFun where-instance FromJSON BinFun where-instance FromJSON Key where-instance FromJSON DescrCol where-instance FromJSON SerializeOrder where-instance FromJSON PayloadCol where-instance FromJSON FrameBounds where-instance FromJSON FrameEnd where-instance FromJSON FrameStart where--instance ToJSON Plan where-instance FromJSON Plan where--data Plan = Plan { tags :: [(AlgNode, [Tag])], roots :: [AlgNode], graph :: [(AlgNode, TableAlgebra)] }- deriving Generic--serializePlan :: (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra) -> BL.ByteString-serializePlan (ts, rs, g) = let tags' = M.toList ts- graph' = M.toList g- in encode $ Plan {tags = tags', roots = rs, graph = graph'}--deserializePlan :: BL.ByteString -> (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra)-deserializePlan s = let Just (Plan ts rs g) = decode s- in (M.fromList ts, rs, M.fromList g)--planToFile :: FilePath -> (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra) -> IO ()-planToFile f t = BL.writeFile f $ serializePlan t--planFromFile :: FilePath -> IO (NodeMap [Tag], [AlgNode], NodeMap TableAlgebra)-planFromFile f = liftM deserializePlan $ BL.readFile f
src/Database/Algebra/Table/Tools/DotGen.hs view
@@ -2,20 +2,21 @@ -- 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 System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO -import Data.Maybe+import Data.Aeson+import Data.ByteString.Lazy.Char8 (pack) -import Data.ByteString.Lazy.Char8 (pack)+import Data.Maybe -import Database.Algebra.Table.Render.Dot-import Database.Algebra.Table.Render.JSON+import Database.Algebra.Dag+import Database.Algebra.Table.Render.Dot -data Options = Options { optInput :: IO String- , optRootNodes :: Maybe [Int]+data Options = Options { optInput :: IO String+ , optRootNodes :: Maybe [Int] } startOptions :: Options@@ -53,9 +54,9 @@ plan <- input - let (tags, rs, m) = deserializePlan $ pack plan- rs' = fromMaybe rs mRootNodes + let dag = fromJust $ decode $ pack plan+ rs = fromMaybe (rootNodes dag) mRootNodes - let dot = renderTADot tags rs' m+ let dot = renderTADot rs (nodeMap dag) putStr dot