haskelldb-2.0: src/Database/HaskellDB/Optimize.hs
-----------------------------------------------------------
-- |
-- Module : Optimize
-- Copyright : Daan Leijen (c) 1999, daan@cs.uu.nl
-- HWT Group (c) 2003, haskelldb-users@lists.sourceforge.net
-- License : BSD-style
--
-- Maintainer : haskelldb-users@lists.sourceforge.net
-- Stability : experimental
-- Portability : non portable
--
-- Defines standard optimizations performed on PrimQuery's
-- (relational expressions).
--
--
-----------------------------------------------------------
module Database.HaskellDB.Optimize (optimize, optimizeCriteria) where
import Control.Exception (assert)
import Data.List (intersect, (\\), union, nub)
import Database.HaskellDB.PrimQuery
-- | Optimize a PrimQuery
optimize :: PrimQuery -> PrimQuery
optimize = hacks
. mergeProject
. removeEmpty
. removeDead
. pushRestrict
. optimizeExprs
-- | Optimize a set of criteria.
optimizeCriteria :: [PrimExpr] -> [PrimExpr]
optimizeCriteria = filter (not . exprIsTrue) . map optimizeExpr
-- | Hacks needed by some back-ends.
-- FIXME: this is silly.
hacks :: PrimQuery -> PrimQuery
hacks = includeOrderFieldsInSelect
-- | HACK: All fields that we order by must also be in the result in
-- PostgreSQL, since we use SELECT DISTINCT.
includeOrderFieldsInSelect :: PrimQuery -> PrimQuery
includeOrderFieldsInSelect =
foldPrimQuery (Empty, BaseTable, proj, Restrict, Binary, Group, Special)
where
proj ass p = Project (ass++ass') p
where ass' = [(a, AttrExpr a) | a <- new ]
new = orderedBy p \\ concatMap (attrInExpr . snd) ass
orderedBy = foldPrimQuery ([], \_ _ -> [], \_ _ -> [],
\_ _ -> [], \_ _ _ -> [], \_ _ -> [], special)
special (Order es) p = attrInOrder es `union` p
special _ p = p
-- | Remove unused attributes from projections.
removeDead :: PrimQuery -> PrimQuery
removeDead query
= removeD (attributes query) query
removeD :: Scheme -- ^ All live attributes (i.e. all attributes
-- that are in the result of the query)
-> PrimQuery
-> PrimQuery
removeD live (Binary op query1 query2)
= assert (all (`elem` (live1 ++ live2)) live)
Binary op (removeD live1 query1) (removeD live2 query2)
where
live1 = live `intersect` attributes query1
live2 = live `intersect` attributes query2
removeD live (Project assoc query)
= assert (all (`elem` (map fst newAssoc)) live)
Project newAssoc (removeD newLive query)
where
-- The live attributes in the nested query.
newLive :: Scheme
newLive = concat (map (attrInExpr . snd) newAssoc)
-- All associations that define attributes that are live
-- or that will be put in a GROUP BY clause.
-- These are the associations that will be kept.
newAssoc :: Assoc
newAssoc = filter (isLive live) assoc
removeD live (Restrict x query)
= Restrict x (removeD (live ++ attrInExpr x) query)
removeD live (Special (Order xs) query)
= Special (Order xs) (removeD (live ++ attrInOrder xs) query)
removeD live (Group cols query) = Group newAssoc (removeD newLive query)
where
newLive :: Scheme
newLive = concat (map (attrInExpr . snd) newAssoc)
newAssoc :: Assoc
newAssoc = filter (isLive live) cols
removeD live query = query
-- | Determines if the given column (attribute/expression pair)
-- exists in the scheme given.
isLive :: Scheme -> (Attribute,PrimExpr) -> Bool
isLive live (attr,expr) = attr `elem` live
schemeOf :: (PrimExpr -> Bool) -> Assoc -> Scheme
schemeOf f = map fst . filter (f . snd)
-- | Remove unused parts of the query
removeEmpty :: PrimQuery -> PrimQuery
removeEmpty
= foldPrimQuery (Empty, BaseTable, project, restrict, binary, group, special)
where
-- Messes up queries without a table, e.g. constant queries
-- disabled by Bjorn Bringert 2004-04-08
--project assoc Empty = Empty
project assoc query | null assoc = query
| otherwise = Project assoc query
restrict x Empty = Empty
restrict x query = Restrict x query
special op Empty = Empty
special op query = Special op query
binary op Empty query = case op of Times -> query
_ -> Empty
binary op query Empty = case op of Times -> query
Difference -> query
_ -> Empty
binary op query1 query2 = Binary op query1 query2
group _ Empty = Empty
group cols query = Group cols query
-- | Collapse adjacent projections
mergeProject :: PrimQuery -> PrimQuery
mergeProject q
= foldPrimQuery (Empty, BaseTable, project, Restrict, Binary, Group, Special) q
where
project assoc1 (Project assoc2 query)
| equal assoc1 assoc2 = Project assoc2 query
| safe assoc1 query = Project (subst assoc1 assoc2) query
where
project assoc query@(Binary Times _ _) = Project assoc query
project assoc (Binary op (Project assoc1 query1)
(Project assoc2 query2))
| safe assoc1 query1 && safe assoc2 query2
= Binary op (Project newAssoc1 query1)
(Project newAssoc2 query2)
where
newAssoc1 = subst assoc assoc1
newAssoc2 = subst assoc assoc2
project assoc query
= Project assoc query
-- Replace columns in a1 with
-- expressions from a2.
subst :: Assoc -- ^ Association that we want to change
-> Assoc -- ^ Association containing the substitutions
-> Assoc
subst a1 a2
= map (\(attr,expr) -> (attr, substAttr a2 expr)) a1
-- It is safe to merge two projections in two cases.
-- 1. All columns in the outer projections are attributes, with no
-- computation. This means they merely copy values from the inner
-- projection to the outer and can be eliminated.
-- 2. The inner projection does not group on any columns.
safe :: Assoc -- ^ Outer projection's columns.
-> PrimQuery -- ^ Inner projection's query.
-> Bool
safe outer innerQuery = all isAttr outer || null (groups innerQuery)
where
isAttr (_, AttrExpr _) = True
isAttr _ = False
-- Are two associations equal?
equal :: Assoc -> Assoc -> Bool
equal assoc1 assoc2 = length assoc1 == length assoc2 &&
(all (\((a1, _),(a2, _)) -> a1 == a2) $ zip assoc1 assoc2)
-- Returns grouped columns for a projection.
groups :: PrimQuery -> Scheme
groups = foldPrimQuery ([], \ _ _ -> [],
\ _ _ -> [], restrict,
\ _ _ _ -> [], group, special)
where
restrict _ rest = rest
group cols _ = map fst cols
special _ rest = rest
-- | Push restrictions down through projections and binary ops.
pushRestrict :: PrimQuery -> PrimQuery
pushRestrict (Binary op query1 query2)
= Binary op (pushRestrict query1) (pushRestrict query2)
pushRestrict (Project assoc query)
= Project assoc (pushRestrict query)
pushRestrict (Group assoc query)
= Group assoc (pushRestrict query)
-- restricts
pushRestrict (Restrict x (Project assoc query))
| safe = Project assoc (pushRestrict (Restrict expr query))
where
-- since we passed a project, we need to replace all attributes
-- with the expression they are bound to by the project
expr = substAttr assoc x
-- aggregate expressions are not allowed in restricts
safe = not (isAggregate expr) && not (hasAggregates query)
hasAggregates (Project _ _) = False
hasAggregates (BaseTable _ _) = False
hasAggregates (Restrict _ qry) = hasAggregates qry
hasAggregates (Group _ _) = True
hasAggregates (Binary _ left right) = hasAggregates left || hasAggregates right
hasAggregates (Special _ qry) = hasAggregates qry
hasAggregates Empty = False
pushRestrict (Restrict x (Binary op query1 query2))
| noneIn1 = Binary op query1 (pushRestrict (Restrict x query2))
| noneIn2 = Binary op (pushRestrict (Restrict x query1)) query2
-- otherwise fall through
where
attrs = attrInExpr x
noneIn1 = null (attrs `intersect` attributes query1)
noneIn2 = null (attrs `intersect` attributes query2)
pushRestrict (Restrict x (query@(Restrict _ _)))
= case (pushed) of
(Restrict _ _) -> Restrict x pushed
_ -> pushRestrict (Restrict x pushed)
where
pushed = pushRestrict query
pushRestrict (Restrict x (Special op query))
= Special op (pushRestrict (Restrict x query))
pushRestrict (Restrict x query)
= Restrict x (pushRestrict query)
-- also push specials
-- Order is only pushed if it does not cause it to
-- end up with non-attribute expressions in the ordering
pushRestrict (Special (Order xs) (Project assoc query))
| safe = Project assoc (pushRestrict (Special (Order xs') query))
where
xs' = [OrderExpr o (substAttr assoc e) | OrderExpr o e <- xs]
safe = and [not (isAggregate e) | OrderExpr _ e <- xs']
-- Top is pushed through Project if there are no aggregates in the project
-- Aggregates can change the number of results.
pushRestrict (Special top@(Top _) (Project assoc query))
| not (any isAggregate (map snd assoc))
= Project assoc (pushRestrict (Special top query))
pushRestrict (Special op (query@(Special _ _)))
= case (pushed) of
(Special _ _) -> Special op pushed
_ -> pushRestrict (Special op pushed)
where
pushed = pushRestrict query
pushRestrict (Special op query)
= Special op (pushRestrict query)
-- otherwise do nothing
pushRestrict query
= query
optimizeExprs :: PrimQuery -> PrimQuery
optimizeExprs = foldPrimQuery (Empty, BaseTable, Project, restr, Binary, Group, Special)
where
restr e q | exprIsTrue e' = q
| otherwise = Restrict e' q
where e' = optimizeExpr e
optimizeExpr :: PrimExpr -> PrimExpr
optimizeExpr = foldPrimExpr (AttrExpr,ConstExpr,bin,un,AggrExpr,CaseExpr,ListExpr,ParamExpr,FunExpr, CastExpr)
where
bin OpAnd e1 e2
| exprIsFalse e1 || exprIsFalse e2 = exprFalse
| exprIsTrue e1 = e2
| exprIsTrue e2 = e1
bin OpOr e1 e2
| exprIsTrue e1 || exprIsTrue e2 = exprTrue
| exprIsFalse e1 = e2
| exprIsFalse e2 = e1
bin OpIn _ (ListExpr []) = exprFalse
bin op e1 e2 = BinExpr op e1 e2
un OpNot (ConstExpr (BoolLit b)) = ConstExpr (BoolLit (not b))
un op e = UnExpr op e
exprTrue :: PrimExpr
exprTrue = ConstExpr (BoolLit True)
exprFalse :: PrimExpr
exprFalse = ConstExpr (BoolLit False)
exprIsTrue :: PrimExpr -> Bool
exprIsTrue (ConstExpr (BoolLit True)) = True
exprIsTrue _ = False
exprIsFalse :: PrimExpr -> Bool
exprIsFalse (ConstExpr (BoolLit False)) = True
exprIsFalse _ = False