algebra-sql-0.1.0.0: src/Database/Algebra/SQL/Render/Query.hs
{-# LANGUAGE TemplateHaskell #-}
-- This file determines the semantics of the 'Query' data structure and all of
-- its sub structures.
module Database.Algebra.SQL.Render.Query
( renderQuery
, renderSelectStmt
) where
import Text.PrettyPrint.ANSI.Leijen ( (<$>)
, (<+>)
, (</>)
, (<>)
, Doc
, align
, bold
, char
, comma
, double
, empty
, fillSep
, float
, hang
, hsep
, indent
, int
, integer
, linebreak
, lparen
, ondullblue
, parens
, punctuate
, red
, rparen
, sep
, squotes
, text
, vcat
)
import Database.Algebra.Impossible
import Database.Algebra.SQL.Query
import Database.Algebra.SQL.Compatibility
enlist :: [Doc] -> Doc
enlist = fillSep . punctuate comma
-- Does the same as enlist but does not break the line.
enlistOnLine :: [Doc] -> Doc
enlistOnLine = hsep . punctuate comma
-- | A keyword.
kw :: String -> Doc
kw = red . text
-- | A single character keyword.
op :: Char -> Doc
op = red . char
-- | Terminate a SQL query.
terminate :: Doc -> Doc
terminate = (<> op ';')
renderQuery :: CompatMode -> Query -> Doc
renderQuery c query = terminate $ case query of
QValueQuery q -> renderValueQuery c q
QDefinitionQuery q -> renderDefinitionQuery c q
renderDefinitionQuery :: CompatMode -> DefinitionQuery -> Doc
renderDefinitionQuery compat (DQMatView query name) =
kw "CREATE MATERIALIZED VIEW"
<+> text name
<+> kw "AS"
</> renderValueQuery compat query
renderDefinitionQuery compat (DQTemporaryTable query name) =
createStmt
<+>
case compat of
PostgreSQL ->
-- PostgreSQL does not accept the default syntax. In order to
-- achieve the same behaviour, the SQL code is rendered differently.
kw "ON COMMIT DROP"
<+> as
<$> indentedQuery
-- Default implementation for SQL:1999 compliant DBMS.
_ ->
as
<$> indentedQuery
-- Create the table with the result of the given value query.
<$> kw "WITH DATA ON COMMIT DROP"
where
createStmt = kw "CREATE LOCAL TEMPORARY TABLE" <+> text name
as = kw "AS"
indentedQuery = indent 4 $ renderValueQuery compat query
renderValueQuery :: CompatMode -> ValueQuery -> Doc
renderValueQuery compat (VQSelect stmt) = renderSelectStmt compat stmt
renderValueQuery compat (VQLiteral vals) =
kw "VALUES" <+> align (sep . punctuate comma $ map renderRow vals)
where renderRow row = parens . enlistOnLine $ map (renderColumnExpr compat) row
renderValueQuery compat (VQWith bindings body) =
hang 4 (kw "WITH" </> enlist (map renderBinding bindings))
<$> renderValueQuery compat body
where renderBinding :: (String, Maybe [String], ValueQuery) -> Doc
renderBinding (name, optCols, query) =
text name
<> renderOptColDefs optCols
<+> kw "AS"
<+> lparen
<$> indent 4 (renderValueQuery compat query)
<$> rparen
renderValueQuery compat (VQBinarySetOperation left right o) =
renderValueQuery compat left
<> linebreak
<$> renderSetOperation o
<> linebreak
<$> renderValueQuery compat right
renderSetOperation :: SetOperation -> Doc
renderSetOperation SOUnionAll = kw "UNION ALL"
renderSetOperation SOExceptAll = kw "EXCEPT ALL"
-- | Render a conjunction list, renders the neutral element, when given the
-- empty list.
renderAndList :: CompatMode -> [ColumnExpr] -> Doc
renderAndList compat l = case l of
[] -> kw "TRUE"
_ -> align $ hsep $ punctuate (linebreak <> kw "AND")
$ map (renderColumnExpr compat) l
renderSelectStmt :: CompatMode -> SelectStmt -> Doc
renderSelectStmt compat stmt =
kw "SELECT"
<+> align ( let sC = enlist $ map (renderSelectColumn compat) $ selectClause stmt
in if distinct stmt
then kw "DISTINCT" <+> sC
else sC
)
<> case fromClause stmt of
[] -> empty
fromParts ->
linebreak
<> kw "FROM"
<+> align ( vcat . punctuate comma
$ map (renderFromPart compat) fromParts
)
<> case whereClause stmt of
[] -> empty
l -> linebreak
<> kw "WHERE"
<+> renderAndList compat l
<> case groupByClause stmt of
[] -> empty
valExpr -> linebreak
<> kw "GROUP BY"
<+> align (enlist $ map (renderColumnExpr compat) valExpr)
<> case orderByClause stmt of
[] -> empty
order -> linebreak
<> kw "ORDER BY"
<+> align ( renderGenericOrderByList renderOrderExpr
compat
order
)
renderOrderExpr :: CompatMode -> OrderExpr -> Doc
renderOrderExpr compat (OE ee dir) =
renderExtendedExpr compat ee
<+> renderSortDirection dir
renderWindowOrderExpr :: CompatMode -> WindowOrderExpr -> Doc
renderWindowOrderExpr compat (WOE ae dir) =
renderAggrExpr compat ae
<+> renderSortDirection dir
-- | Render a list of generic order expressions.
renderGenericOrderByList :: (CompatMode -> o -> Doc) -> CompatMode -> [o] -> Doc
renderGenericOrderByList renderGenericOrderExpr compat =
enlistOnLine . map (renderGenericOrderExpr compat)
renderWindowOrderByList :: CompatMode -> [WindowOrderExpr] -> Doc
renderWindowOrderByList compat wos =
kw "ORDER BY" <+> renderGenericOrderByList renderWindowOrderExpr compat wos
renderFrameSpec :: FrameSpec -> Doc
renderFrameSpec (FHalfOpen fs) = kw "ROWS" <+> renderFrameStart fs
renderFrameSpec (FClosed fs fe) = kw "ROWS BETWEEN"
<+> renderFrameStart fs
<+> kw "AND"
<+> renderFrameEnd fe
renderFrameStart :: FrameStart -> Doc
renderFrameStart FSUnboundPrec = text "UNBOUNDED PRECEDING"
renderFrameStart (FSValPrec i) = int i <+> text "PRECEDING"
renderFrameStart FSCurrRow = text "CURRENT ROW"
renderFrameEnd :: FrameEnd -> Doc
renderFrameEnd FEUnboundFol = text "UNBOUNDED FOLLOWING"
renderFrameEnd (FEValFol i) = int i <+> text "FOLLOWING"
renderFrameEnd FECurrRow = text "CURRENT ROW"
renderSortDirection :: SortDirection -> Doc
renderSortDirection Ascending = kw "ASC"
renderSortDirection Descending = kw "DESC"
-- | Render a list of columns as definition within a from clause or within
-- a common table expression.
renderOptColDefs :: Maybe [String] -> Doc
renderOptColDefs = maybe empty colDoc
where colDoc = parens . enlistOnLine . map text
renderFromPart :: CompatMode -> FromPart -> Doc
renderFromPart _ (FPAlias (FETableReference n) alias _) =
-- Don't use positional mapping on table references, since they are mapped
-- by their name.
text n
<+> kw "AS"
<+> text alias
renderFromPart compat (FPAlias expr alias optCols) =
renderFromExpr compat expr
<+> kw "AS"
<+> text alias
<> renderOptColDefs optCols
renderSubQuery :: CompatMode -> ValueQuery -> Doc
renderSubQuery compat q = lparen <+> align (renderValueQuery compat q) <$> rparen
renderFromExpr :: CompatMode -> FromExpr -> Doc
renderFromExpr compat (FESubQuery q) = renderSubQuery compat q
renderFromExpr _ (FEVariable v) = ondullblue $ int v
renderFromExpr _ (FETableReference n) = text n
-- | Renders an optional prefix.
renderOptPrefix :: Maybe String -> Doc
renderOptPrefix = maybe empty $ (<> char '.') . text
renderSelectColumn :: CompatMode -> SelectColumn -> Doc
renderSelectColumn compat (SCAlias expr name) = renderExtendedExpr compat expr
<+> kw "AS"
<+> text name
renderSelectColumn compat (SCExpr expr) = renderExtendedExpr compat expr
renderExtendedExpr :: CompatMode -> ExtendedExpr -> Doc
renderExtendedExpr compat (EEBase v) = renderExtendedExprBase compat v
renderExtendedExpr compat (EEWinFun wfun partExprs order mFrameSpec) =
renderWindowFunction compat wfun
<+> kw "OVER"
<+> parens (partitionByDoc <> orderByDoc <> frameSpecDoc)
where
partitionByDoc = case partExprs of
[] -> empty
_ -> kw "PARTITION BY"
</> enlist (map (renderAggrExpr compat) partExprs)
<> linebreak
orderByDoc = case order of
[] -> empty
_ -> renderWindowOrderByList compat order <> linebreak
frameSpecDoc = maybe empty (\fs -> renderFrameSpec fs) mFrameSpec
renderExtendedExpr compat (EEAggrExpr ae) =
renderAggrExpr compat ae
renderAggrExpr :: CompatMode -> AggrExpr -> Doc
renderAggrExpr compat e = case e of
AEBase ve ->
renderValueExprTemplate renderAggrExpr compat ve
AEAggregate optVE aggr ->
renderAggregateFunction compat aggr
<> parens (maybe (char '*') (renderColumnExpr compat) optVE)
-- | Generic 'ValueExprTemplate' renderer.
renderValueExprTemplate :: (CompatMode -> a -> Doc)
-> CompatMode
-> ValueExprTemplate a
-> Doc
renderValueExprTemplate renderRec compat ve = case ve of
VEValue v -> renderValue v
VEColumn n optPrefix -> renderOptPrefix optPrefix
<> text n
VECast v ty ->
kw "CAST" <> parens castDoc
where castDoc = renderRec compat v
<+> kw "AS" <+> renderDataType ty
VEBinApp f a b -> parens $ renderRec compat a
<+> renderBinaryFunction f
<+> renderRec compat b
VEUnApp (UFSubString f t) a -> renderSubString renderRec compat f t a
VEUnApp f a ->
parens $ renderUnaryFunction f <> parens (renderRec compat a)
VENot a -> parens $ kw "NOT" <+> renderRec compat a
VEExists q -> kw "EXISTS" <+> renderSubQuery compat q
VEIn v q -> parens $ renderRec compat v
<+> kw "IN"
<+> renderSubQuery compat q
VECase c t e ->
text "CASE WHEN" <+> renderRec compat c
<+> text "THEN"
<+> renderRec compat t
<+> text "ELSE"
<+> renderRec compat e
<+> text "END"
renderSubString :: (CompatMode -> a -> Doc)
-> CompatMode
-> Integer
-> Integer
-> a
-> Doc
renderSubString renderRec compat from to argExpr =
case compat of
SQL99 -> kw "substring" <> parens (renderRec compat argExpr
<+> text "from" <+> integer from
<+> text "for" <+> integer to)
PostgreSQL -> kw "substr" <> parens (hsep $ punctuate comma [ renderRec compat argExpr
, integer from
, integer to
])
MonetDB -> kw "substring" <> parens (hsep $ punctuate comma [ renderRec compat argExpr
, integer from
, integer to
])
-- | Render a 'ExtendedExprBase' with the generic renderer.
renderExtendedExprBase :: CompatMode -> ExtendedExprBase -> Doc
renderExtendedExprBase = renderValueExprTemplate renderExtendedExpr
-- | Render a 'ColumnExprBase' with the generic renderer.
renderColumnExprBase :: CompatMode -> ColumnExprBase -> Doc
renderColumnExprBase = renderValueExprTemplate renderColumnExpr
renderAggregateFunction :: CompatMode -> AggregateFunction -> Doc
renderAggregateFunction _ AFAvg = kw "AVG"
renderAggregateFunction _ AFMax = kw "MAX"
renderAggregateFunction _ AFMin = kw "MIN"
renderAggregateFunction _ AFSum = kw "SUM"
renderAggregateFunction _ AFCount = kw "COUNT"
renderAggregateFunction PostgreSQL AFAll = kw "BOOL_AND"
renderAggregateFunction SQL99 AFAll = kw "EVERY"
renderAggregateFunction MonetDB AFAll = kw "MIN"
renderAggregateFunction PostgreSQL AFAny = kw "BOOL_OR"
renderAggregateFunction SQL99 AFAny = kw "SOME"
renderAggregateFunction MonetDB AFAny = kw "MAX"
renderFunCall :: String -> Doc -> Doc
renderFunCall funName funArg = kw funName <> parens funArg
renderWindowFunction :: CompatMode -> WindowFunction -> Doc
renderWindowFunction _ WFRowNumber = renderFunCall "ROW_NUMBER" empty
renderWindowFunction _ WFDenseRank = renderFunCall "DENSE_RANK" empty
renderWindowFunction _ WFRank = renderFunCall "RANK" empty
renderWindowFunction MonetDB _ = error "MonetDB does not support window aggregates"
renderWindowFunction c (WFAvg a) = renderFunCall "AVG" (renderColumnExpr c a)
renderWindowFunction c (WFMax a) = renderFunCall "MAX" (renderColumnExpr c a)
renderWindowFunction c (WFMin a) = renderFunCall "MIN" (renderColumnExpr c a)
renderWindowFunction c (WFSum a) = renderFunCall "SUM" (renderColumnExpr c a)
renderWindowFunction c (WFFirstValue a) = renderFunCall "first_value" (renderColumnExpr c a)
renderWindowFunction c (WFLastValue a) = renderFunCall "last_value" (renderColumnExpr c a)
renderWindowFunction _ WFCount = renderFunCall "COUNT" (text "*")
renderWindowFunction PostgreSQL (WFAll a) = renderFunCall "bool_and"
(renderColumnExpr PostgreSQL a)
renderWindowFunction SQL99 (WFAll a) = renderFunCall "EVERY"
(renderColumnExpr SQL99 a)
renderWindowFunction PostgreSQL (WFAny a) = renderFunCall "bool_or"
(renderColumnExpr PostgreSQL a)
renderWindowFunction SQL99 (WFAny a) = renderFunCall "SOME"
(renderColumnExpr SQL99 a)
renderColumnExpr :: CompatMode -> ColumnExpr -> Doc
renderColumnExpr compat (CEBase e) = renderColumnExprBase compat e
renderBinaryFunction :: BinaryFunction -> Doc
renderBinaryFunction BFPlus = op '+'
renderBinaryFunction BFMinus = op '-'
renderBinaryFunction BFTimes = op '*'
renderBinaryFunction BFDiv = op '/'
renderBinaryFunction BFModulo = op '%'
renderBinaryFunction BFContains = op '~'
renderBinaryFunction BFSimilarTo = kw "SIMILAR TO"
renderBinaryFunction BFLike = kw "LIKE"
renderBinaryFunction BFConcat = kw "||"
renderBinaryFunction BFGreaterThan = op '>'
renderBinaryFunction BFGreaterEqual = kw ">="
renderBinaryFunction BFLowerThan = op '<'
renderBinaryFunction BFLowerEqual = kw "<="
renderBinaryFunction BFEqual = op '='
renderBinaryFunction BFNotEqual = kw "<>"
renderBinaryFunction BFAnd = kw "AND"
renderBinaryFunction BFOr = kw "OR"
renderUnaryFunction :: UnaryFunction -> Doc
renderUnaryFunction UFSin = kw "sin"
renderUnaryFunction UFCos = kw "cos"
renderUnaryFunction UFTan = kw "tan"
renderUnaryFunction UFLog = kw "log"
renderUnaryFunction UFSqrt = kw "sqrt"
renderUnaryFunction UFExp = kw "exp"
renderUnaryFunction UFASin = kw "asin"
renderUnaryFunction UFACos = kw "acos"
renderUnaryFunction UFATan = kw "atan"
-- The substring combinator is rendered speciall
renderUnaryFunction UFSubString{} = $impossible
renderDataType :: DataType -> Doc
renderDataType DTInteger = kw "INTEGER"
renderDataType DTDecimal = kw "DECIMAL"
renderDataType DTDoublePrecision = kw "DOUBLE PRECISION"
renderDataType DTText = kw "TEXT"
renderDataType DTBoolean = kw "BOOLEAN"
literal :: Doc -> Doc
literal = bold
renderValue :: Value -> Doc
renderValue v = case v of
VInteger i -> literal $ integer i
VDecimal d -> literal $ float d
VDoublePrecision d -> literal $ double d
VText str -> literal $ squotes $ text str
VBoolean b -> kw $ if b then "TRUE" else "FALSE"
VNull -> literal $ text "null"