diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/algebra-sql.cabal b/algebra-sql.cabal --- a/algebra-sql.cabal +++ b/algebra-sql.cabal @@ -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 () 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 diff --git a/src/Database/Algebra/SQL/File.hs b/src/Database/Algebra/SQL/File.hs --- a/src/Database/Algebra/SQL/File.hs +++ b/src/Database/Algebra/SQL/File.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Materialization.hs b/src/Database/Algebra/SQL/Materialization.hs --- a/src/Database/Algebra/SQL/Materialization.hs +++ b/src/Database/Algebra/SQL/Materialization.hs @@ -1,5 +1,5 @@ -- Provides a basic toolset for materialization functions. -module Database.Algebra.SQL.Materialization +module Database.Algebra.SQL.Materialization ( MatFun ) where diff --git a/src/Database/Algebra/SQL/Materialization/CTE.hs b/src/Database/Algebra/SQL/Materialization/CTE.hs --- a/src/Database/Algebra/SQL/Materialization/CTE.hs +++ b/src/Database/Algebra/SQL/Materialization/CTE.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Materialization/Combined.hs b/src/Database/Algebra/SQL/Materialization/Combined.hs --- a/src/Database/Algebra/SQL/Materialization/Combined.hs +++ b/src/Database/Algebra/SQL/Materialization/Combined.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Query.hs b/src/Database/Algebra/SQL/Query.hs --- a/src/Database/Algebra/SQL/Query.hs +++ b/src/Database/Algebra/SQL/Query.hs @@ -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.) diff --git a/src/Database/Algebra/SQL/Query/Substitution.hs b/src/Database/Algebra/SQL/Query/Substitution.hs --- a/src/Database/Algebra/SQL/Query/Substitution.hs +++ b/src/Database/Algebra/SQL/Query/Substitution.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Query/Util.hs b/src/Database/Algebra/SQL/Query/Util.hs --- a/src/Database/Algebra/SQL/Query/Util.hs +++ b/src/Database/Algebra/SQL/Query/Util.hs @@ -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 = - + diff --git a/src/Database/Algebra/SQL/Render/Query.hs b/src/Database/Algebra/SQL/Render/Query.hs --- a/src/Database/Algebra/SQL/Render/Query.hs +++ b/src/Database/Algebra/SQL/Render/Query.hs @@ -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) diff --git a/src/Database/Algebra/SQL/Render/Tile.hs b/src/Database/Algebra/SQL/Render/Tile.hs --- a/src/Database/Algebra/SQL/Render/Tile.hs +++ b/src/Database/Algebra/SQL/Render/Tile.hs @@ -3,11 +3,12 @@ ) where +import Prelude hiding ( (<$>) ) import Text.PrettyPrint.ANSI.Leijen ( (<$>) , (<+>) , (<>) , Doc - , align + , align , black , bold , empty diff --git a/src/Database/Algebra/SQL/Termination.hs b/src/Database/Algebra/SQL/Termination.hs --- a/src/Database/Algebra/SQL/Termination.hs +++ b/src/Database/Algebra/SQL/Termination.hs @@ -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. diff --git a/src/Database/Algebra/SQL/Tile.hs b/src/Database/Algebra/SQL/Tile.hs --- a/src/Database/Algebra/SQL/Tile.hs +++ b/src/Database/Algebra/SQL/Tile.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Tile/Flatten.hs b/src/Database/Algebra/SQL/Tile/Flatten.hs --- a/src/Database/Algebra/SQL/Tile/Flatten.hs +++ b/src/Database/Algebra/SQL/Tile/Flatten.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Tools/Gen.hs b/src/Database/Algebra/SQL/Tools/Gen.hs --- a/src/Database/Algebra/SQL/Tools/Gen.hs +++ b/src/Database/Algebra/SQL/Tools/Gen.hs @@ -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 diff --git a/src/Database/Algebra/SQL/Util.hs b/src/Database/Algebra/SQL/Util.hs --- a/src/Database/Algebra/SQL/Util.hs +++ b/src/Database/Algebra/SQL/Util.hs @@ -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). diff --git a/src/Database/Algebra/Table/Construct.hs b/src/Database/Algebra/Table/Construct.hs --- a/src/Database/Algebra/Table/Construct.hs +++ b/src/Database/Algebra/Table/Construct.hs @@ -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) diff --git a/src/Database/Algebra/Table/Lang.hs b/src/Database/Algebra/Table/Lang.hs --- a/src/Database/Algebra/Table/Lang.hs +++ b/src/Database/Algebra/Table/Lang.hs @@ -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 -- ^ PRECEDING | FSCurrRow -- ^ CURRENT ROW - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show) -- | Window frame end specification data FrameEnd = FECurrRow -- ^ CURRENT ROW | FEValFol Int -- ^ 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 diff --git a/src/Database/Algebra/Table/Render/Dot.hs b/src/Database/Algebra/Table/Render/Dot.hs --- a/src/Database/Algebra/Table/Render/Dot.hs +++ b/src/Database/Algebra/Table/Render/Dot.hs @@ -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 diff --git a/src/Database/Algebra/Table/Render/JSON.hs b/src/Database/Algebra/Table/Render/JSON.hs deleted file mode 100644 --- a/src/Database/Algebra/Table/Render/JSON.hs +++ /dev/null @@ -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 diff --git a/src/Database/Algebra/Table/Tools/DotGen.hs b/src/Database/Algebra/Table/Tools/DotGen.hs --- a/src/Database/Algebra/Table/Tools/DotGen.hs +++ b/src/Database/Algebra/Table/Tools/DotGen.hs @@ -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