haskelldb-0.13: 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)
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 | hasAggregate = groupAssoc ++ liveAssoc
| otherwise = liveAssoc
where
-- when an aggregate expression is in the
-- association we check
-- if an attribute is explicitly added by the user
-- and not already live
-- (ie. "extend" is called), if so we should
-- keep it live to be added in a GROUP BY
-- clause.
groupAssoc = filter (not.isLive)
$ filter newAttr assoc
-- Does the association define a new attribute?
-- (i.e. not just pass on an existing one
-- from the nested query)
newAttr :: (Attribute,PrimExpr) -> Bool
newAttr (attr,AttrExpr name) = (attr /= name)
newAttr _ = True
-- Is any live attribute bound to an aggregate expression?
hasAggregate :: Bool
hasAggregate = any (isAggregate.snd) liveAssoc
-- All associations that define live attributes.
liveAssoc :: Assoc
liveAssoc = filter isLive assoc
-- Is the attribute defined by the association live?
isLive :: (Attribute,PrimExpr) -> Bool
isLive (attr,expr) = attr `elem` live
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)
-- Filter dead columns from group expression, as they are not used. Note
-- live columns are NOT just those that are in the select, but also those
-- used in restrictions.
removeD live (Group cols query)
= Group cols (removeD live query)
where
liveCols = filter ((`elem` live) . fst) cols
removeD live query
= query
-- | 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)
| safe newAssoc = Project newAssoc query
where
newAssoc = subst assoc1 assoc2
-- "hmm, is this always true ?" (Daan Leijen)
-- "no, not true when assoc uses fields defined in only
-- one of assoc1 or assoc2, which happens
-- when op == Times" (Bjorn Bringert)
project assoc query@(Binary Times _ _) = Project assoc query
project assoc (Binary op (Project assoc1 query1)
(Project assoc2 query2))
| safe newAssoc1 && safe newAssoc2
= Binary op (Project newAssoc1 query1)
(Project newAssoc2 query2)
where
newAssoc1 = subst assoc assoc1
newAssoc2 = subst assoc assoc2
project assoc query
= Project assoc query
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
safe :: Assoc -> Bool
safe assoc
= not (any (isAggregate.snd) assoc) || all (isAggregate . snd) assoc
-- | 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)
-- 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)
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