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