module Database.HaskellDB.Optimize (optimize, optimizeCriteria) where
import Control.Exception (assert)
import Data.List (intersect,(\\),union)
import Database.HaskellDB.PrimQuery
optimize :: PrimQuery -> PrimQuery
optimize = hacks
. mergeProject
. removeEmpty
. removeDead
. pushRestrict
. optimizeExprs
optimizeCriteria :: [PrimExpr] -> [PrimExpr]
optimizeCriteria = filter (not . exprIsTrue) . map optimizeExpr
hacks :: PrimQuery -> PrimQuery
hacks = includeOrderFieldsInSelect
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
removeDead :: PrimQuery -> PrimQuery
removeDead query
= removeD (attributes query) query
removeD :: Scheme
-> 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
newLive :: Scheme
newLive = concat (map (attrInExpr . snd) newAssoc)
newAssoc :: Assoc
newAssoc | hasAggregate = groupAssoc ++ liveAssoc
| otherwise = liveAssoc
where
groupAssoc = filter (not.isLive)
$ filter newAttr assoc
newAttr :: (Attribute,PrimExpr) -> Bool
newAttr (attr,AttrExpr name) = (attr /= name)
newAttr _ = True
hasAggregate :: Bool
hasAggregate = any (isAggregate.snd) liveAssoc
liveAssoc :: Assoc
liveAssoc = filter isLive assoc
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)
removeD live (Group cols query)
= Group liveCols (removeD (live ++ (map fst liveCols)) query)
where
liveCols = filter ((`elem` live) . fst) cols
removeD live query
= query
removeEmpty :: PrimQuery -> PrimQuery
removeEmpty
= foldPrimQuery (Empty, BaseTable, project, restrict, binary, group, special)
where
project assoc query | null assoc = Empty
| 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
mergeProject :: PrimQuery -> PrimQuery
mergeProject
= foldPrimQuery (Empty,BaseTable,project,Restrict,Binary,Group, Special)
where
project assoc1 (Project assoc2 query)
| safe newAssoc = Project newAssoc query
where
newAssoc = subst assoc1 assoc2
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
-> Assoc
-> Assoc
subst a1 a2
= map (\(attr,expr) -> (attr, substAttr a2 expr)) a1
safe :: Assoc -> Bool
safe assoc
= not (any (isAggregate.snd) assoc)
pushRestrict :: PrimQuery -> PrimQuery
pushRestrict (Binary op query1 query2)
= Binary op (pushRestrict query1) (pushRestrict query2)
pushRestrict (Project assoc query)
= Project assoc (pushRestrict query)
pushRestrict (Restrict x (Project assoc query))
| safe = Project assoc (pushRestrict (Restrict expr query))
where
expr = substAttr assoc x
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
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)
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']
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)
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)
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