algebra-sql-0.3.0.0: src/Database/Algebra/SQL/Tile.hs
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.Algebra.SQL.Tile
( TileTree (TileNode, ReferenceLeaf)
, TileChildren
, ExternalReference
, InternalReference
, DependencyList
, TransformResult
, transform
, TADag
) where
-- TODO maybe split this file into the tile definition
-- and the transform things.
-- TODO embed closing tiles as subqueries (are there any sub queries which are
-- correlated?)? (reader?)
-- TODO isMultiReferenced special case: check for same parent !!
import Control.Arrow (second)
import Control.Monad.RWS.Strict
import qualified Data.DList as DL (DList, singleton)
import qualified Data.List as L
import qualified Data.IntMap as IntMap
import Data.Maybe
import GHC.Exts hiding (inline)
import qualified Database.Algebra.Dag as D
import qualified Database.Algebra.Dag.Common as C
import Database.Algebra.Impossible
import qualified Database.Algebra.Table.Lang as A
import qualified Database.Algebra.SQL.Query as Q
import Database.Algebra.SQL.Termination
import Database.Algebra.SQL.Query.Util
-- | A tile internal reference type.
type InternalReference = Q.ReferenceType
-- | The type used to reference table expressions outside of a tile.
type ExternalReference = Int
-- | Aliased tile children, where the first part is the alias used within the
-- 'Q.SelectStmt'.
type TileChildren = [(InternalReference, TileTree)]
-- | Defines the tile tree structure.
data TileTree = -- | A tile: The first argument determines which features the
-- 'Q.SelectStmt' uses.
TileNode FeatureSet Q.SelectStmt TileChildren
-- | A reference pointing to another TileTree: The second
-- argument specifies the columns of the referenced table
-- expression.
| ReferenceLeaf ExternalReference [String]
-- | Table algebra DAGs
type TADag = D.AlgebraDag A.TableAlgebra
-- | Association list (where dependencies should be ordered topologically).
type DependencyList = DL.DList (ExternalReference, TileTree)
-- | A combination of types which need to be modified state wise while
-- transforming:
-- * The processed nodes with multiple parents.
--
-- * The current state of the table id generator.
--
-- * The current state of the variable id generator.
--
data TransformState = TS
{ multiParentNodes :: IntMap.IntMap ( ExternalReference
, [String]
)
, tableIdGen :: ExternalReference
, aliasIdGen :: Int
, varIdGen :: InternalReference
}
-- | The initial state.
sInitial :: TransformState
sInitial = TS IntMap.empty 0 0 0
-- | Adds a new binding to the state.
sAddBinding :: C.AlgNode -- ^ The key as a node with multiple parents.
-> ( ExternalReference
, [String]
) -- ^ Name of the reference and its columns.
-> TransformState
-> TransformState
sAddBinding node t st =
st { multiParentNodes = IntMap.insert node t $ multiParentNodes st}
-- | Tries to look up a binding for a node.
sLookupBinding :: C.AlgNode
-> TransformState
-> Maybe (ExternalReference, [String])
sLookupBinding n = IntMap.lookup n . multiParentNodes
-- | The transform monad is used for transforming DAGs into dense tiles, it
-- is built from:
--
-- * A reader for the DAG
--
-- * A writer for outputting the dependencies
--
-- * A state for generating fresh names and maintain the mapping of nodes
--
type Transform = RWS TADag DependencyList TransformState
-- | A table expression id generator using the state within the
-- 'Transform' type.
freshTableId :: Transform ExternalReference
freshTableId = do
st <- get
let tid = tableIdGen st
put $ st { tableIdGen = succ tid }
return tid
freshAlias :: Transform String
freshAlias = do
st <- get
let aid = aliasIdGen st
put $ st { aliasIdGen = succ aid }
return $ 'a' : show aid
-- | A variable identifier generator.
freshVariableId :: Transform InternalReference
freshVariableId = do
st <- get
let vid = varIdGen st
put $ st { varIdGen = succ vid }
return vid
-- | Unpack values (or run computation).
runTransform :: Transform a
-> TADag -- ^ The used DAG.
-> TransformState -- ^ The inital state.
-> (a, DependencyList)
runTransform = evalRWS
-- | Check if node has more than one parent.
isMultiReferenced :: C.AlgNode
-> TADag
-> Bool
isMultiReferenced n dag = case D.parents n dag of
-- Has at least 2 parents.
_:(_:_) -> True
_ -> False
-- | Get the column schema of a 'TileNode'.
getSchemaTileTree :: TileTree -> [String]
getSchemaTileTree (ReferenceLeaf _ s) = s
getSchemaTileTree (TileNode _ body _) = getSchemaSelectStmt body
-- | Get the column schema of a 'Q.SelectStmt'.
getSchemaSelectStmt :: Q.SelectStmt -> [String]
getSchemaSelectStmt s = map Q.sName $ Q.selectClause s
-- | The result of the 'transform' function.
type TransformResult = ([TileTree], DependencyList)
-- | Transform a 'TADag', while swapping out repeatedly used sub expressions
-- (nodes with more than one parent).
-- A 'TADag' can have multiple root nodes, and therefore the function returns a
-- list of root tiles and their dependencies.
transform :: TADag -> TransformResult
transform dag = runTransform result dag sInitial
where
rootNodes = D.rootNodes dag
result = mapM transformNode rootNodes
-- | This function basically checks for already referenced nodes with more than
-- one parent, returning a reference to already computed 'TileTree's.
transformNode :: C.AlgNode -> Transform TileTree
transformNode n = do
op <- asks $ D.operator n
-- allowBranch indicates whether multi reference nodes shall be split
-- for this operator, resulting in multiple equal branches. (Treeify)
let (allowBranch, transformOp) = case op of
-- Ignore branching for nullary operators.
(C.NullaryOp nop) -> (False, transformNullaryOp nop)
(C.UnOp uop c) -> (True, transformUnOp uop c)
(C.BinOp bop c0 c1) ->
case bop of
A.ThetaJoin _ -> (False, transformBinOp bop c0 c1)
_ -> (True, transformBinOp bop c0 c1)
(C.TerOp () _ _ _) -> $impossible
multiRef <- asks $ isMultiReferenced n
if allowBranch && multiRef
then do
-- Lookup whether there exists a binding for the node in the current
-- state.
possibleBinding <- gets $ sLookupBinding n
case possibleBinding of
-- If so, just return it.
Just (b, s) -> return $ ReferenceLeaf b s
-- Otherwise add it.
Nothing -> do
resultingTile <- transformOp
-- Generate a name for the sub tree.
tableId <- freshTableId
-- Add the tree to the writer.
tell $ DL.singleton (tableId, resultingTile)
let schema = getSchemaTileTree resultingTile
-- Add binding for this node (to prevent recalculation).
modify $ sAddBinding n (tableId, schema)
return $ ReferenceLeaf tableId schema
else transformOp
transformNullaryOp :: A.NullOp -> Transform TileTree
transformNullaryOp (A.LitTable (tuples, typedSchema)) = do
tableAlias <- freshAlias
let -- Abstracts over the differences.
tile otherFeatures tuples' wClause =
TileNode (otherFeatures <> tableF)
emptySelectStmt
{ Q.selectClause = columnsFromSchema tableAlias schema
, Q.fromClause =
[ Q.FPAlias (Q.FESubQuery $ Q.VQLiteral tuples')
tableAlias
$ Just schema
]
, Q.whereClause = wClause
}
[]
return $ case tuples of
[] -> tile (projectF <> filterF)
[map (castedNull . snd) typedSchema]
[Q.CEBase . Q.VEValue $ Q.VBoolean False]
_ -> tile projectF
(map (map translateLit) tuples)
[]
where
schema = map fst typedSchema
castedNull ty = Q.CEBase $ Q.VEUnApp (Q.UFCast $ translateATy ty)
(Q.CEBase $ Q.VEValue Q.VNull)
translateLit = Q.CEBase . Q.VEValue . translateAVal
transformNullaryOp (A.TableRef (name, typedSchema, _)) = do
tableAlias <- freshAlias
return $ TileNode (projectF <> tableF)
emptySelectStmt
{ -- Map the columns of the table reference to the given
-- column names.
Q.selectClause = columnsFromSchema tableAlias schema
, Q.fromClause =
[ Q.FPAlias (Q.FETableReference name)
tableAlias
-- Map to old column name.
$ Just schema
]
}
[]
where
schema = map fst typedSchema
-- | Abstraction for rank operators.
transformUnOpRank :: -- ExtendedExpr constructor.
Q.WindowFunction
-> (String, [A.SortSpec])
-> C.AlgNode
-> Transform TileTree
transformUnOpRank rankFun (name, sortList) =
attachColFunUnOp colFun $ projectF <> windowFunctionF
where
colFun sClause = Q.SCAlias rankExpr name
where
rankExpr = Q.EEWinFun rankFun
[]
(asWindowOrderExprList sClause sortList)
Nothing
transformUnOp :: A.UnOp -> C.AlgNode -> Transform TileTree
transformUnOp (A.Serialize (ref, key, ord, items)) c = do
(ctor, select, children) <- transformTerminated' c $ projectF <> sortF
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
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
]
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 = projs , Q.orderByClause = sortExprs }
children
transformUnOp (A.RowNum (name, sortList, partExprs)) c =
attachColFunUnOp colFun
(projectF <> windowFunctionF)
c
where
colFun sClause = Q.SCAlias rowNumExpr name
where
-- ROW_NUMBER() OVER (PARTITION BY p ORDER BY s)
rowNumExpr = Q.EEWinFun Q.WFRowNumber
(map (translateExprAE $ Just sClause) partExprs)
(asWindowOrderExprList sClause sortList)
Nothing
transformUnOp (A.WinFun ((name, fun), partExprs, sortExprs, mFrameSpec)) c =
attachColFunUnOp colFun
(projectF <> windowFunctionF)
c
where
colFun sClause = Q.SCAlias winFunExpr name
where
winFunExpr = Q.EEWinFun (translateWindowFunction translateE fun)
(map (translateExprAE $ Just sClause) partExprs)
(asWindowOrderExprList sClause sortExprs)
(fmap translateFrameSpec mFrameSpec)
translateE = translateExprCE $ Just sClause
transformUnOp (A.RowRank inf) c = transformUnOpRank Q.WFDenseRank inf c
transformUnOp (A.Rank inf) c = transformUnOpRank Q.WFRank inf c
transformUnOp (A.Project projList) c = do
(ctor, select, children) <- transformTerminated' c projectF
let -- Inlining is obligatory here, since we possibly eliminate referenced
-- columns. ('translateExpr' inlines columns.)
translateAlias :: (A.Attr, A.Expr) -> Q.SelectColumn
translateAlias (col, expr) = Q.SCAlias translatedExpr col
where
translatedExpr = translateExprEE (Just $ Q.selectClause select) expr
return $ ctor select
-- Replace the select clause with the projection list.
{ Q.selectClause = map translateAlias projList }
-- But use the old children.
children
transformUnOp (A.Select expr) c = do
(ctor, select, children) <- transformTerminated' c filterF
return $ ctor ( appendToWhere ( translateExprCE
(Just $ Q.selectClause select)
expr
)
select
)
children
transformUnOp (A.Distinct ()) c = do
(ctor, select, children) <- transformTerminated' c dupElimF
-- Keep everything but set distinct.
return $ ctor select { Q.distinct = True } children
transformUnOp (A.Aggr (aggrs, partExprMapping)) c = do
(ctor, select, children) <- transformTerminated' c $ projectF <> aggrAndGroupingF
let justSClause = Just $ Q.selectClause select
translateE = translateExprCE justSClause
-- Inlining here is obligatory, since we could eliminate referenced
-- columns. (This is similar to projection.)
aggrToEE (a, n) =
Q.SCAlias ( let (fun, optExpr) = translateAggrType a
in Q.EEAggrExpr
$ Q.AEAggregate (liftM translateE optExpr)
fun
)
n
partColumnExprs = map (second translateE) partExprMapping
partExtendedExprs = map (second $ translateExprEE $ justSClause)
partExprMapping
wrapSCAlias (name, extendedExpr)
=
Q.SCAlias extendedExpr name
return $ ctor select
{ Q.selectClause =
map wrapSCAlias partExtendedExprs
++ map aggrToEE aggrs
, -- Since SQL treats numbers in the group by clause as
-- column indices, filter them out. (They do not change
-- the semantics anyway.)
Q.groupByClause =
filter affectsSortOrderCE $ map snd partColumnExprs
}
children
-- | Generates a new 'TileTree' by attaching a column, generated by a function
-- taking the select clause.
attachColFunUnOp :: ([Q.SelectColumn] -> Q.SelectColumn)
-> FeatureSet
-> C.AlgNode
-> Transform TileTree
attachColFunUnOp colFun opFeatures c = do
(ctor, select, children) <- transformTerminated' c opFeatures
let sClause = Q.selectClause select
-- Attach a column to the select clause generated by the
-- given function.
return $ case colFun sClause of
col@(Q.SCAlias _ name) ->
ctor select { Q.selectClause = col : pruneCol name sClause }
children
col@Q.SCExpr{} ->
ctor select { Q.selectClause = col : sClause }
children
pruneCol :: String -> [Q.SelectColumn] -> [Q.SelectColumn]
pruneCol n cols = filter namePred cols
where
namePred (Q.SCAlias _ n') | n == n' = False
namePred _ = True
-- | Abstracts over binary set operation operators.
transformBinSetOp :: Q.SetOperation
-> C.AlgNode
-> C.AlgNode
-> Transform TileTree
transformBinSetOp setOp c0 c1 = do
-- Use one tile to get the schema information.
(_, select0, children0) <- transformTerminated c0 noneF
(_, select1, children1) <- transformTerminated c1 noneF
-- Impose a canonical order on entries in the SELECT clauses to
-- ensure that schemata of the set operator inputs match.
-- 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 }
tableAlias <- freshAlias
-- Take the schema of the first one, but could also be from the second one,
-- since we assume they are equal.
let schema = getSchemaSelectStmt select0'
return $ TileNode (projectF <> tableF)
emptySelectStmt
{ Q.selectClause =
columnsFromSchema tableAlias schema
, Q.fromClause =
[ Q.FPAlias ( Q.FESubQuery
$ Q.VQBinarySetOperation
(Q.VQSelect select0')
(Q.VQSelect select1')
setOp
)
tableAlias
$ Just schema
]
}
$ children0 ++ children1
-- | Perform a cross join between two nodes.
transformBinCrossJoin :: C.AlgNode
-> C.AlgNode
-> Transform ( FeatureSet
, Q.SelectStmt
, TileChildren
)
transformBinCrossJoin c0 c1 = do
(childFeatures0, select0, children0) <- transformF c0
(childFeatures1, select1, children1) <- transformF c1
-- We can simply concatenate everything, because all things are prefixed and
-- cross join is associative.
return ( mconcat [childFeatures0, childFeatures1, opFeatures]
, emptySelectStmt
{ Q.selectClause =
Q.selectClause select0 ++ Q.selectClause select1
, Q.fromClause =
Q.fromClause select0 ++ Q.fromClause select1
, Q.whereClause = Q.whereClause select0
++ Q.whereClause select1
}
, children0 ++ children1
)
where
transformF c = transformTerminated c opFeatures
opFeatures = projectF <> tableF <> filterF
transformBinOp :: A.BinOp
-> C.AlgNode
-> C.AlgNode
-> Transform TileTree
transformBinOp (A.Cross ()) c0 c1 = do
(f, s, c) <- transformBinCrossJoin c0 c1
return $ TileNode f s c
transformBinOp (A.EqJoin (lName, rName)) c0 c1 = do
(childrenFeatures, select, children) <- transformBinCrossJoin c0 c1
let sClause = Q.selectClause select
cond = Q.CEBase $ Q.VEBinApp Q.BFEqual (inlineCE sClause lName)
$ inlineCE sClause rName
-- 'transformBinCrossJoin' already has the 'filterF' feature.
return $ TileNode childrenFeatures (appendToWhere cond select) children
transformBinOp (A.ThetaJoin conditions) c0 c1 = do
when (null conditions) $impossible
(childrenFeatures, select, children) <- transformBinCrossJoin c0 c1
let sClause = Q.selectClause select
conds = map (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.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
-> (Q.ColumnExpr -> Q.ColumnExpr)
-> Transform TileTree
transformExistsJoin conditions c0 c1 wrapFun = do
when (null conditions) $impossible
(ctor0, select0, children0) <- transformTerminated' c0 filterF
-- Ignore operator features, since it will be nested and therefore
-- terminated.
(_, select1, children1) <- transformTerminated c1 noneF
let ctor s = ctor0 s $ children0 ++ children1
-- Split the conditions into the first equality condition found and the
-- remaining ones.
case foldr findEq (Nothing, []) conditions of
-- We did not find an equality condition, use the EXISTS construct.
(Nothing, _) -> do
-- TODO in case we do not have merge conditions we can simply use
-- the unmergeable but less nested select stmt on the right side
let outerCond = wrapFun . Q.CEBase
. Q.VEExists
$ Q.VQSelect innerSelect
innerSelect = appendAllToWhere innerConds select1
innerConds = map f conditions
f = translateJoinCond (Q.selectClause select0)
$ Q.selectClause select1
return $ ctor (appendToWhere outerCond select0)
-- We did find an equality condition, use it with the IN construct.
(Just (l, r), conditions') -> do
let -- Embedd the right query into the where clause of the left one.
leftCond =
wrapFun . Q.CEBase
. Q.VEIn (translateExprCE (Just lSClause) l)
$ rightSelect'
-- If the nested query is a simple selection from a
-- literal table, use the literal table directly:
-- SELECT t.c FROM (VALUES ...) AS t(c)
-- =>
-- VALUES ...
rightSelect' =
case rightSelect of
Q.VQSelect
(Q.SelectStmt
[Q.SCExpr (Q.EEBase (Q.VEColumn colName (Just tabName)))]
False
[Q.FPAlias (Q.FESubQuery (Q.VQLiteral rows)) tabName' (Just [colName'])]
[]
[]
[]) | colName == colName' && tabName == tabName' -> Q.VQLiteral rows
_ -> rightSelect
-- Embedd all conditions in the right select, and set select
-- clause to the right part of the equal join condition.
rightSelect = Q.VQSelect $ appendAllToWhere innerConds select1
{ Q.selectClause = [rightSCol] }
innerConds = map f conditions'
f = translateJoinCond lSClause rSClause
rightSCol = Q.SCExpr (translateExprEE (Just rSClause) r)
lSClause = Q.selectClause select0
rSClause = Q.selectClause select1
return $ ctor (appendToWhere leftCond select0)
where
-- Tries to extract a join condition for usage in the IN sql construct.
findEq c (Just eqCols, r) = (Just eqCols, c:r)
findEq c@(left, right, j) (Nothing, r) = case j of
A.EqJ -> (Just (left, right), r)
_ -> (Nothing, c:r)
-- | Terminates a SQL fragment when suggested. Returns the resulting
-- 'FeatureSet' of the child, the 'Q.SelectStmt' and its children.
transformTerminated :: C.AlgNode
-> FeatureSet
-> Transform (FeatureSet, Q.SelectStmt, TileChildren)
transformTerminated n topFs = do
tile <- transformNode n
case tile of
TileNode bottomFs body children
| topFs `terminatesOver` bottomFs -> do
tableAlias <- freshAlias
let schema = getSchemaSelectStmt body
return ( projectF <> tableF
, emptySelectStmt
{ Q.selectClause =
columnsFromSchema tableAlias schema
, Q.fromClause =
[mkSubQuery body tableAlias $ Just schema]
}
, children
)
| otherwise ->
return (bottomFs, body, children)
ReferenceLeaf r s -> do
(sel, cs) <- embedExternalReference r s
return (projectF <> tableF, sel, cs)
-- | Does the same as 'transformTerminated', but further handles combining of
-- the 'FeatureSet' and applies it to the constructor.
transformTerminated' :: C.AlgNode
-> FeatureSet
-> Transform ( Q.SelectStmt -> TileChildren -> TileTree
, Q.SelectStmt
, TileChildren
)
transformTerminated' n topFs = do
(fs, select, cs) <- transformTerminated n topFs
return (TileNode $ fs <> topFs, select, cs)
-- | Embeds an external reference into a 'Q.SelectStmt'.
embedExternalReference :: ExternalReference
-> [String]
-> Transform (Q.SelectStmt, TileChildren)
embedExternalReference extRef schema = do
tableAlias <- freshAlias
varId <- freshVariableId
return ( emptySelectStmt
{ -- Use the schema to construct the select clause.
Q.selectClause =
columnsFromSchema tableAlias schema
, Q.fromClause =
[Q.FPAlias (Q.FEVariable varId) tableAlias $ Just schema]
}
, [(varId, ReferenceLeaf extRef schema)]
)
-- | Generate a select clause with column names from a schema and a prefix.
columnsFromSchema :: String -> [String] -> [Q.SelectColumn]
columnsFromSchema p = map $ asSelectColumn p
-- | Creates 'Q.SelectColumn' which points at a prefixed column with the same
-- name.
asSelectColumn :: String
-> String
-> Q.SelectColumn
asSelectColumn tablePrefix columnName =
Q.SCAlias (Q.EEBase $ mkPCol tablePrefix columnName) columnName
-- Translates a '[A.SortSpec]' into a '[Q.WindowOrderExpr]'. Column names will
-- be inlined as a 'Q.AggrExpr', constant ones will be discarded.
asWindowOrderExprList :: [Q.SelectColumn]
-> [A.SortSpec]
-> [Q.WindowOrderExpr]
asWindowOrderExprList sClause si =
filter (affectsSortOrderAE . Q.woExpr)
$ translateSortInf si (translateExprAE $ Just sClause)
-- | Search the select clause for a specific column definition and return it as
-- 'Q.ColumnExpr'.
inlineCE :: [Q.SelectColumn]
-> String
-> Q.ColumnExpr
inlineCE sClause col =
fromMaybe (Q.CEBase $ Q.VEColumn col Nothing)
$ convertEEtoCE $ inlineEE sClause col
-- | Search the select clause for a specific column definition and return it as
-- 'Q.AggrExpr'.
inlineAE :: [Q.SelectColumn]
-> String
-> Q.AggrExpr
inlineAE sClause col =
fromMaybe (Q.AEBase $ Q.VEColumn col Nothing)
$ convertEEtoAE $ inlineEE sClause col
-- | Search the select clause for a specific column definition and return it as
-- 'Q.ExtendedExpr'.
inlineEE :: [Q.SelectColumn]
-> String
-> Q.ExtendedExpr
inlineEE sClause col =
fromMaybe (Q.EEBase $ mkCol col) $ foldr f Nothing sClause
where
f sc r = case sc of
Q.SCAlias expr alias | col == alias -> return expr
_ -> r
-- | Generic base converter for the value expression template. Since types do
-- not have equal functionality, conversion can fail.
convertEEBaseTemplate :: (Q.ExtendedExpr -> Maybe a)
-> Q.ExtendedExprBase
-> Maybe (Q.ValueExprTemplate a)
convertEEBaseTemplate convertEEBaseRec eeb = case eeb of
Q.VEValue v -> return $ Q.VEValue v
Q.VEColumn n p -> return $ Q.VEColumn n p
Q.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.VEExists q -> return $ Q.VEExists q
Q.VEIn rec q -> do
e <- convertEEBaseRec rec
return $ Q.VEIn e q
Q.VECase crec trec erec -> do
c <- convertEEBaseRec crec
t <- convertEEBaseRec trec
e <- convertEEBaseRec erec
return $ Q.VECase c t e
-- | Converts an 'Q.ExtendedExpr' to a 'Q.ColumnExpr', if possible.
convertEEtoCE :: Q.ExtendedExpr -> Maybe Q.ColumnExpr
convertEEtoCE ee = case ee of
Q.EEBase eeb -> do
ceb <- convertEEBaseTemplate convertEEtoCE eeb
return $ Q.CEBase ceb
_ -> Nothing
-- | Converts an 'Q.ExtendedExpr' to a 'Q.AggrExpr', if possible.
convertEEtoAE :: Q.ExtendedExpr -> Maybe Q.AggrExpr
convertEEtoAE ee = case ee of
Q.EEBase eeb -> do
aeb <- convertEEBaseTemplate convertEEtoAE eeb
return $ Q.AEBase aeb
Q.EEAggrExpr ae -> return ae
_ -> Nothing
-- | Shorthand to make an unprefixed column.
mkCol :: String
-> Q.ValueExprTemplate a
mkCol c = Q.VEColumn c Nothing
appendToWhere :: Q.ColumnExpr -- ^ The expression added with logical and.
-> Q.SelectStmt -- ^ The select statement to add to.
-> Q.SelectStmt -- ^ The result.
appendToWhere cond select =
select { Q.whereClause = cond : Q.whereClause select }
-- | Append predicate expressions to the WHERE clause of a select
-- statement.
appendAllToWhere :: [Q.ColumnExpr]
-> Q.SelectStmt
-> Q.SelectStmt
appendAllToWhere conds select =
select { Q.whereClause = conds ++ Q.whereClause select }
-- | Translate 'A.JoinRel' into 'Q.BinaryFunction'.
translateJoinRel :: A.JoinRel
-> Q.BinaryFunction
translateJoinRel rel = case rel of
A.EqJ -> Q.BFEqual
A.GtJ -> Q.BFGreaterThan
A.GeJ -> Q.BFGreaterEqual
A.LtJ -> Q.BFLowerThan
A.LeJ -> Q.BFLowerEqual
A.NeJ -> Q.BFNotEqual
translateFrameSpec :: A.FrameBounds -> Q.FrameSpec
translateFrameSpec (A.HalfOpenFrame fs) = Q.FHalfOpen $ translateFrameStart fs
translateFrameSpec (A.ClosedFrame fs fe) = Q.FClosed (translateFrameStart fs)
(translateFrameEnd fe)
translateFrameStart :: A.FrameStart -> Q.FrameStart
translateFrameStart A.FSUnboundPrec = Q.FSUnboundPrec
translateFrameStart (A.FSValPrec i) = Q.FSValPrec i
translateFrameStart A.FSCurrRow = Q.FSCurrRow
translateFrameEnd :: A.FrameEnd -> Q.FrameEnd
translateFrameEnd A.FEUnboundFol = Q.FEUnboundFol
translateFrameEnd (A.FEValFol i) = Q.FEValFol i
translateFrameEnd A.FECurrRow = Q.FECurrRow
translateWindowFunction :: (A.Expr -> Q.ColumnExpr) -> A.WinFun -> Q.WindowFunction
translateWindowFunction translateExpr wfun = case wfun of
A.WinMax e -> Q.WFMax $ translateExpr e
A.WinMin e -> Q.WFMin $ translateExpr e
A.WinSum e -> Q.WFSum $ translateExpr e
A.WinAvg e -> Q.WFAvg $ translateExpr e
A.WinAll e -> Q.WFAll $ translateExpr e
A.WinAny e -> Q.WFAny $ translateExpr e
A.WinFirstValue e -> Q.WFFirstValue $ translateExpr e
A.WinLastValue e -> Q.WFLastValue $ translateExpr e
A.WinCount -> Q.WFCount
translateAggrType :: A.AggrType
-> (Q.AggregateFunction, Maybe A.Expr)
translateAggrType aggr = case aggr of
A.Avg e -> (Q.AFAvg, Just e)
A.Max e -> (Q.AFMax, Just e)
A.Min e -> (Q.AFMin, Just e)
A.Sum e -> (Q.AFSum, Just e)
A.Count e -> (Q.AFCount, Just e)
A.CountStar -> (Q.AFCount, Nothing)
A.All e -> (Q.AFAll, Just e)
A.Any e -> (Q.AFAny, Just e)
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 $ Q.VEUnApp (translateUnFun f) (rec optSelectClause e)
A.ColE n -> case optSelectClause of
Just s -> inline s n
Nothing -> wrap $ Q.VEColumn n mPrefix
A.ConstE v -> wrap $ Q.VEValue $ translateAVal v
translateExprCE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ColumnExpr
translateExprCE = translateExprTempl translateExprCE Q.CEBase inlineCE Nothing
translateExprEE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.ExtendedExpr
translateExprEE = translateExprTempl translateExprEE Q.EEBase inlineEE Nothing
translateExprAE :: Maybe [Q.SelectColumn] -> A.Expr -> Q.AggrExpr
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
A.Lt -> Q.BFLowerThan
A.GtE -> Q.BFGreaterEqual
A.LtE -> Q.BFLowerEqual
A.Eq -> Q.BFEqual
A.NEq -> Q.BFNotEqual
A.And -> Q.BFAnd
A.Or -> Q.BFOr
A.Plus -> Q.BFPlus
A.Minus -> Q.BFMinus
A.Times -> Q.BFTimes
A.Div -> Q.BFDiv
A.Modulo -> Q.BFModulo
A.Contains -> Q.BFContains
A.SimilarTo -> Q.BFSimilarTo
A.Like -> Q.BFLike
A.Concat -> Q.BFConcat
A.Coalesce -> Q.BFCoalesce
-- | Translate sort information into '[Q.WindowOrderExpr]', using the column
-- function, which takes a 'String'.
translateSortInf :: [A.SortSpec]
-> (A.Expr -> Q.AggrExpr)
-> [Q.WindowOrderExpr]
translateSortInf sortInfos colFun = map toWOE sortInfos
where
toWOE (n, d) = Q.WOE (colFun n) (translateSortDir d)
-- | Translate a single join condition into it's 'Q.ColumnExpr' equivalent.
-- 'A.Expr' contained within the join condition are inlined with the
-- corresponding select clauses.
translateJoinCond :: [Q.SelectColumn] -- ^ Left select clause.
-> [Q.SelectColumn] -- ^ Right select clause.
-> (A.Expr, A.Expr, A.JoinRel)
-> Q.ColumnExpr
translateJoinCond lSelectClause rSelectClause (l, r, j) =
Q.CEBase $ Q.VEBinApp (translateJoinRel j)
(translateExprCE (Just lSelectClause) l)
(translateExprCE (Just rSelectClause) r)
translateSortDir :: A.SortDir -> Q.SortDirection
translateSortDir d = case d of
A.Asc -> Q.Ascending
A.Desc -> Q.Descending
translateAVal :: A.AVal -> Q.Value
translateAVal v = case v of
A.VInt i -> Q.VInteger i
A.VStr s -> Q.VText s
A.VBool b -> Q.VBoolean b
A.VDouble d -> Q.VDoublePrecision d
A.VDec d -> Q.VDecimal d
A.VDate d -> Q.VDate d
translateATy :: A.ATy -> Q.DataType
translateATy t = case t of
A.AInt -> Q.DTInteger
A.AStr -> Q.DTText
A.ABool -> Q.DTBoolean
A.ADec -> Q.DTDecimal
A.ADouble -> Q.DTDoublePrecision
A.ADate -> Q.DTDate