{-------------------------------------------------------------------------------------
-
- Preprocess abstract syntax trees, remove backward steps, and optimize
- Programmer: Leonidas Fegaras
- Email: fegaras@cse.uta.edu
- Web: http://lambda.uta.edu/
- Creation: 05/01/08, last update: 01/05/09
-
- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.
- This material is provided as is, with absolutely no warranty expressed or implied.
- Any use is at your own risk. Permission is hereby granted to use or copy this program
- for any purpose, provided the above notices are retained on all copies.
-
--------------------------------------------------------------------------------------}
module Text.XML.HXQ.Optimizer(optimize,subst) where
import Control.Monad
import HXML(AttList)
import Text.XML.HXQ.Parser
import Text.XML.HXQ.XTree
import Text.XML.HXQ.OptionalDB
import Data.List
empty = Ast "call" [Avar "empty"]
true = Ast "call" [Avar "true"]
false = Ast "call" [Avar "false"]
distinct :: Eq a => [a] -> [a]
distinct = foldl (\r a -> if elem a r then r else r++[a]) []
-- collect attribute constructions inside element constructions
collect_attributes :: Ast -> (Ast,[Ast])
collect_attributes (Ast "attribute_construction" [attr,value])
= (Ast "call" [Avar "empty"],[Ast "pair" [attr,value]])
collect_attributes (Ast "call" [Avar "concatenate",x,y])
= let (cx,ax) = collect_attributes x
(cy,ay) = collect_attributes y
in (Ast "call" [Avar "concatenate",cx,cy],ax++ay)
collect_attributes (Ast "append" es)
= let (s,a) = foldr (\e (r,ar) -> let (cx,ax) = collect_attributes e in (cx:r,ax++ar)) ([],[]) es
in (Ast "append" s,a)
collect_attributes (Ast "step" (step:tag:e:preds))
= let (ce,ae) = collect_attributes e
in (Ast "step" (step:tag:ce:preds),ae)
collect_attributes e = (e,[])
-- does the expression contain a $var/.. term?
parentOfVar :: Ast -> String -> Bool
parentOfVar (Ast "step" [Avar "parent",_,Avar x]) var = x == var
parentOfVar (Ast "let" [Avar v,s,_]) var | var == v = parentOfVar s var
parentOfVar (Ast "for" [Avar v,Avar i,s,_]) var | var == v || var == i = parentOfVar s var
parentOfVar (Ast _ args) var = or (map (\x -> parentOfVar x var) args)
parentOfVar _ _ = False
-- replace $var/.. with $nvar
replaceParentOfVar :: Ast -> String -> String -> Ast
replaceParentOfVar (Ast "step" [Avar "parent",Astring "*",Avar x]) var nvar
| x == var
= Avar nvar
replaceParentOfVar (Ast "step" [Avar "parent",Astring tag,Avar x]) var nvar
| x == var
= Ast "step" [Avar "self",Astring tag,Avar nvar]
replaceParentOfVar (Ast "let" [Avar v,s,b]) var nvar | var == v
= Ast "let" [Avar v,replaceParentOfVar s var nvar,b]
replaceParentOfVar (Ast "for" [Avar v,Avar i,s,b]) var nvar | var == v || var == i
= Ast "for" [Avar v,Avar i,replaceParentOfVar s var nvar,b]
replaceParentOfVar (Ast f args) var nvar
= Ast f (map (\x -> replaceParentOfVar x var nvar) args)
replaceParentOfVar e _ _ = e
-- Rules to extract the parent of an XQuery expression
-- For every XQuery x and predicates p1 ... pn and for s in [tag,*,@attr]:
-- x/s[p1]...[pn]/.. -> x[s[p1]...[pn]]
-- x//s[p1]...[pn]/.. -> x// *[s[p1]...[pn]]
removeParent :: Ast -> Maybe (Ast,Ast,Bool,Ast)
removeParent (Ast "predicate" [c,x])
= do (nx,cond,childp,tag) <- removeParent x
return (Ast "predicate" [c,nx],cond,childp,tag)
removeParent (Ast "step" (Avar "self":tag:x:preds))
= do (nx,cond,childp,t) <- removeParent x
return (Ast "step" (Avar "self":tag:nx:preds),cond,childp,t)
removeParent (Ast "step" (Avar "child":tag:x:preds))
= Just (Ast "step" (Avar "child":tag:Avar ".":preds),x,True,tag)
removeParent (Ast "step" (Avar "descendant-or-self":tag:x:preds))
= Just (Ast "step" (Avar "child":tag:Avar ".":preds),
Ast "step" [Avar "descendant-or-self",Astring "*",x],True,tag)
removeParent (Ast "step" (Avar "descendant":tag:x:preds))
= Just (Ast "step" (Avar "child":tag:Avar ".":preds),
Ast "step" [Avar "descendant-or-self",Astring "*",x],True,tag)
removeParent (Ast "step" (Avar "attribute":tag:x:preds))
= Just (Ast "step" (Avar "attribute":tag:Avar ".":preds),x,False,tag)
removeParent (Ast "step" (Avar "attribute-descendant":tag:x:preds))
= Just (Ast "step" (Avar "attribute":tag:Avar ".":preds),
Ast "step" [Avar "descendant-or-self",Astring "*",x],False,tag)
removeParent (Ast "step" (Avar "ancestor-or-self":tag:x:preds))
= Just (true,Ast "step" (Avar "ancestor":tag:x:preds),False,tag)
removeParent (Ast "step" (Avar "preceding-sibling":tag:x:preds))
= do (nx,cond,childp,t) <- removeParent x
return (Ast "step" (Avar "child":tag:Avar ".":preds),cond,childp,t)
removeParent (Ast "step" (Avar "following-sibling":tag:x:preds))
= do (nx,cond,childp,t) <- removeParent x
return (Ast "step" (Avar "child":tag:Avar ".":preds),cond,childp,t)
removeParent e = Nothing
-- to speed up // * step, find possible immediate tagged children, if any (eg, x in // */x)
tagged_children :: String -> Ast -> [String]
tagged_children context (Ast "step" (Avar "child":Astring tag:Avar v:_))
| v == context
= [tag]
tagged_children _ (Ast "step" _) = []
tagged_children context (Ast "let" [Avar var,source,body])
= if context == "." || context == var
then tagged_children context source
else (tagged_children context source)++(tagged_children context body)
tagged_children context (Ast "for" [Avar var,Avar ivar,source,body])
= if context == "." || context == var || context == ivar
then tagged_children context source
else (tagged_children context source)++(tagged_children context body)
tagged_children context (Ast _ xs) = concatMap (tagged_children context) xs
tagged_children _ _ = []
-- Preprocessing and simplification of ASTs
simplify :: Ast -> Ast
-- must be done bottom-up: /../..
simplify (Ast "step" [Avar "parent",t,z@(Ast "step" [Avar "parent",_,x])])
= let nz = simplify z
in simplify (Ast "step" [Avar "parent",t,nz])
-- get rid of a parent step
simplify (Ast "step" (Avar "parent":tag:x:preds))
= case removeParent x of
Just (cond,nx,_,_)
-> Ast "step" (Avar "self":tag:simplify nx:simplify cond:preds)
Nothing -> Ast "step" (Avar "parent":tag:simplify x:map simplify preds)
-- remove $var/.. in a let-FLWOR
simplify (Ast "let" [Avar var,source,body])
| parentOfVar body var
= case removeParent source of
Just (cond,nx,childp,tag)
-> simplify (Ast "let" [Avar (var++"_parent"),Ast "step" (Avar "self":Astring "*":nx:[cond]),
Ast "let" [Avar var,
Ast "step" [ Avar (if childp
then "child"
else "attribute"),
tag, Avar (var++"_parent") ],
replaceParentOfVar body var (var++"_parent")]])
Nothing -> Ast "let" [Avar var,simplify source,simplify body]
-- remove $var/.. from a for-FLWOR
simplify (Ast "for" [Avar var,Avar "$",source,body])
| parentOfVar body var
= case removeParent source of
Just (cond,nx,childp,tag)
-> simplify (Ast "for" [Avar (var++"_parent"),Avar "$",Ast "step" (Avar "self":Astring "*":nx:[cond]),
Ast "for" [Avar var,Avar "$",
Ast "step" [ Avar (if childp
then "child"
else "attribute"),
tag, Avar (var++"_parent") ],
replaceParentOfVar body var (var++"_parent")]])
Nothing -> Ast "for" [Avar var,Avar "$",simplify source,simplify body]
-- pull out attributes from a general element construction
simplify (Ast "element_construction" [tag,Ast "attributes" as,content])
= let (nc,attrs) = collect_attributes content
in case attrs++as of
(Ast "pair" [Astring "_id",id]):(Ast "pair" [Astring "_parent",parent]):atts
-> simplify (Ast "construction" [tag,id,parent,Ast "attributes" atts,nc])
atts -> simplify (Ast "construction" [tag,Astring "0",Ast "call" [Avar "empty"],Ast "attributes" atts,nc])
-- if / / * collect all children tagnames to use descendant_any
simplify (Ast "for" [Avar var,i,Ast "step" (Avar "descendant":Astring "*":path:preds),body])
| not (null ((tagged_children var body))) || any (not . null . (tagged_children ".")) preds
= let ctags = distinct ((tagged_children var body)++(concatMap (tagged_children ".") preds))
tags = Ast "tags" (map Avar ctags)
in simplify (Ast "for" [Avar var,i,Ast "step" (Avar "descendant_any":tags:path:preds),body])
simplify (Ast "step" (Avar "child":Astring tag:Ast "step" (Avar "descendant":Astring "*":path:preds):preds2))
= let ctags = distinct(tag:(concatMap (tagged_children ".") preds))
tags = Ast "tags" (map Avar ctags)
in simplify (Ast "step" (Avar "child":Astring tag:Ast "step" (Avar "descendant_any":tags:path:preds):preds2))
simplify (Ast "step" (Avar "descendant":Astring "*":path:preds))
| any (not . null . (tagged_children ".")) preds
= let ctags = distinct (concatMap (tagged_children ".") preds)
tags = Ast "tags" (map Avar ctags)
in simplify (Ast "step" (Avar "descendant_any":tags:path:preds))
-- expand the wrapper of a stored document
simplify (Ast "call" [Avar "publish",Astring dbpath,Astring name])
= simplify (publishXmlDoc dbpath name False)
-- default
simplify (Ast n args) = Ast n (map simplify args)
simplify e = e
-- simplify e/tag
taggedElement :: [Ast] -> String -> Maybe [Ast]
taggedElement (e@(Ast "construction" [Astring ctag,_,_,_,x]):xs) tag
| ctag == tag || tag == "*"
= do s <- taggedElement xs tag
return (e:s)
taggedElement ((Ast "construction" [_,_,_,_,_]):xs) tag
= taggedElement xs tag
taggedElement ((Ast "call" [Avar "concatenate",x,y]):xs) tag
= do tx <- taggedElement (x:xs) tag
ty <- taggedElement (y:xs) tag
return (tx++ty)
taggedElement ((Astring _):xs) tag
= taggedElement xs tag
taggedElement ((Aint _):xs) tag
= taggedElement xs tag
taggedElement (e:xs) tag = Nothing
taggedElement [] _ = Just []
sqlComparisson = [("=","="),("eq","="),("<=","<="),(">=",">="),("!=","!="),(">",">"),
("<","<"),("ne","!="),("gt",">"),("lt","<"),("ge",">="),("le","<=")]
sqlBoolean = [("and","and"),("or","or")]
-- Can this be transformed to an SQL predicate?
sqlPredicate :: [String] -> Ast -> Bool
sqlPredicate tables e
= case e of
Ast "step" (Avar "child":Astring tag:Avar v:preds)
-> (elem v tables) && (all (sqlPredicate tables) preds)
Ast "construction" [_,_,_,_,Ast "append" xs]
-> all (sqlPredicate tables) xs
Ast "call" [Avar "data",x]
-> sqlPredicate tables x
Ast "call" [Avar "text",x]
-> sqlPredicate tables x
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> (sqlExpr tables x) && (sqlExpr tables y)
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) sqlBoolean
-> (sqlPredicate tables x) && (sqlPredicate tables y)
_ -> False
where sqlExpr tables e
= case e of
Astring s -> True
Aint n -> True
Ast "step" (Avar "child":Astring tag:Avar v:preds)
-> elem v tables
Ast "construction" [_,_,_,_,Ast "append" xs]
-> all (sqlExpr tables) xs
Ast "call" [Avar "data",x]
-> sqlExpr tables x
Ast "call" [Avar "text",x]
-> sqlExpr tables x
Ast "for" [Avar v,_,Ast "call" ((Avar "SQL"):_),x]
-> sqlExpr (v:tables) x
_ -> False
-- Convert a predicate AST to an SQL predicate that uses the tables
predToSQL :: [String] -> Ast -> (String,[Ast],[String])
predToSQL tables e
= case e of
Ast "step" [Avar "child",Astring tag,Avar v]
-> if (elem v tables)
then ("",[],[])
else error ("Cannot convert to an SQL predicate: "++show e)
Ast "step" (Avar "child":Astring tag:Avar v:pred:preds)
-> if (elem v tables) && (all (sqlPredicate tables) preds)
then foldl (\(p',ps',ts') (p,ps,ts) -> (p' ++ " and " ++ p,ps++ps,union ts' ts))
(predToSQL tables pred)
(map (predToSQL tables) preds)
else error ("Cannot convert to an SQL predicate: "++show e)
Ast "construction" [_,_,_,_,Ast "append" xs]
-> orAll (map (predToSQL tables) xs)
Ast "call" [Avar "data",x]
-> predToSQL tables x
Ast "call" [Avar "text",x]
-> predToSQL tables x
Ast "call" [Avar cmp,Ast "for" [Avar v,i,Ast "call" [Avar "SQL",_,Ast "call" ((Avar "tables"):t),pred],x],y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> let ts = [ x | Avar x <- t ]
(p,ps,ts') = predToSQL (tables++ts) (call "and" [Ast "call" [Avar cmp,x,y],pred])
in (p,ps,union ts' ts)
Ast "call" [Avar cmp,x,Ast "for" [Avar v,i,Ast "call" [Avar "SQL",_,Ast "call" ((Avar "tables"):t),pred]],y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> let ts = [ x | Avar x <- t ]
(p,ps,ts') = predToSQL (tables++ts) (call "and" [Ast "call" [Avar cmp,x,y],pred])
in (p,ps,union ts' ts)
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> let (nx,vx,px,tx) = expToSQL tables x
(ny,vy,py,ty) = expToSQL tables y
p = if (null vx) && (null vy) then "" else foldl (\r p -> r++" and "++p) "" (px++py)
in if nx == ""
then (ny,vx,union tx ty)
else if ny == ""
then (nx++p,vy,union tx ty)
else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlComparisson)) ++ " " ++ ny++p,vx++vy,union tx ty)
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) sqlBoolean
-> let (nx,vx,tx) = predToSQL tables x
(ny,vy,ty) = predToSQL tables y
in if nx == ""
then (ny,vy,union tx ty)
else if ny == ""
then (nx,vx,union tx ty)
else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlBoolean)) ++ " " ++ ny,vx++vy,union tx ty)
_ -> error ("Cannot convert to an SQL predicate: "++show e)
where expToSQL :: [String] -> Ast -> (String,[Ast],[String],[String])
expToSQL tables e
= case e of
Astring s -> ("\'"++s++"\'",[],[],[])
Aint n -> (show n,[],[],[])
Ast "step" [Avar "child",Astring tag,Avar v]
-> if elem v tables
then (v++"."++tag,[],[],[])
else ("?",[e],[],[])
Ast "step" (Avar "child":Astring tag:Avar v:pred:preds)
-> let (p,ps,ts) = foldl (\(p',ps',ts') (p,ps,ts) -> (p' ++ " and " ++ p,ps'++ps,union ts' ts))
(predToSQL tables pred)
(map (predToSQL tables) preds)
in if elem v tables
then (v++"."++tag,ps,[p],ts)
else ("?",e:ps,[p],ts)
Ast "construction" [_,_,_,_,Ast "append" [x]]
-> expToSQL tables x
Ast "call" [Avar "data",x]
-> expToSQL tables x
Ast "call" [Avar "text",x]
-> expToSQL tables x
_ -> ("?",[e],[],[])
orAll [x] = x
orAll (x:xs) = foldl (\(a,as,at) (b,bs,bt) -> ("("++a++" or "++b++")",as++bs,union at bt)) x xs
-- Convert an AST to an SQL query
makeSQL :: [String] -> [Ast] -> Ast -> [Ast] -> (String,[Ast])
makeSQL tables fromTables pred cols
= let tnames = [ x | Avar x <- fromTables ]
ts = combine tnames
cs = combine [ x | Avar x <- cols ]
vars (Ast n args) = concatMap vars args
vars (Avar v) | not (elem v tnames) = [v]
vars _ = []
combine [] = ""
combine [x] = x
combine (x:xs) = x++", "++combine xs
in if pred == Ast "call" [Avar "true"]
then (if null cs
then "select * from "++ts
else "select "++cs++" from "++ts,[])
else let (p,args,nts) = predToSQL (tables++tnames) pred
pp = if p=="" then "" else " where "++p
in (if null cs
then "select * from "++combine (union tnames nts)++pp
else "select "++cs++" from "++combine (union tnames nts)++pp,args)
findAttr :: String -> [Ast] -> Ast
findAttr tag ((Ast "pair" [n@(Astring a),v]):xs)
| a==tag || tag=="*"
= case findAttr tag xs of
Ast "call" [Avar "empty"] -> Ast "attribute_construction" [n,v]
z -> Ast "call" [Avar "concatenate",Ast "attribute_construction" [n,v],z]
findAttr tag (_:xs) = findAttr tag xs
findAttr _ [] = empty
andAll :: [Ast] -> Ast
andAll [] = true
andAll [x] = x
andAll (x:xs) = foldl (\a r -> call "and" [a,r]) x xs
orAll :: [Ast] -> Ast
orAll [] = true
orAll [x] = x
orAll (x:xs) = foldl (\a r -> call "or" [a,r]) x xs
occursContext :: Ast -> Int
occursContext e
= case e of
Avar "." -> 1
Ast "let" _ -> 0
Ast "for" _ -> 0
Ast "call" [Avar "SQL",s,f,w]
-> occursContext w
Ast "step" (step:tag:x:preds)
-> occursContext x
Ast n xs -> sum (map occursContext xs)
_ -> 0
substContext :: Ast -> Ast -> Ast
substContext e b
= case b of
Avar "." -> e
Ast "let" _ -> b
Ast "for" _ -> b
Ast "call" [Avar "SQL",s,f,w]
-> Ast "call" [Avar "SQL",s,f,substContext e w]
Ast "step" (step:tag:x:preds)
-> Ast "step" (step:tag:(substContext e x):preds)
Ast n xs -> Ast n (map (substContext e) xs)
_ -> b
occurs :: String -> Ast -> Int
occurs v e
= case e of
Avar w | v==w -> 1
Ast "let" [Avar w,s,_] | v==w -> occurs v s
Ast "for" [Avar w,Avar i,s,_] | v==w || v==i -> occurs v s
Ast "call" [Avar "SQL",s,f,w]
-> occurs v w
Ast n xs -> sum (map (occurs v) xs)
_ -> 0
subst :: String -> Ast -> Ast -> Ast
subst v e b
= case b of
Avar w | v==w -> e
Ast "let" [Avar w,s,_] | v==w -> subst v e s
Ast "for" [Avar w,Avar i,s,_] | v==w || v==i -> subst v e s
Ast "call" [Avar "SQL",s,f,w]
-> Ast "call" [Avar "SQL",s,f,subst v e w]
Ast n xs -> Ast n (map (subst v e) xs)
_ -> b
dependsOnPosition :: Bool -> Ast -> Bool
dependsOnPosition contextp e
= case e of
Avar "." -> contextp
Ast "call" [Avar "position"] -> True
Ast "call" [Avar "last"] -> True
Ast "step" (step:tag:x:_)
-> dependsOnPosition contextp x
Ast _ xs -> any (dependsOnPosition contextp) xs
_ -> False
wellFormedPredicate :: Bool -> Ast -> Bool
wellFormedPredicate contextp e
= case e of
Ast "step" (step:tag:x:preds)
-> not (dependsOnPosition contextp x)
Ast "construction" xs
-> not (any (dependsOnPosition contextp) xs)
Ast "call" [Avar "not",x]
-> not (dependsOnPosition contextp x)
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) (sqlComparisson++sqlBoolean)
-> not (dependsOnPosition contextp x)
&& not (dependsOnPosition contextp y)
_ -> False
splitSqlPredicate :: [String] -> Ast -> Maybe (Ast,[Ast])
splitSqlPredicate tables (Ast "call" [Avar "and",p1,p2])
= case (splitSqlPredicate tables p1,splitSqlPredicate tables p2) of
(Nothing,Nothing) -> Nothing
(Nothing,Just(pp1,pp2))
-> Just(pp1,p1:pp2)
(Just(pp1,pp2),Nothing)
-> Just(pp1,p2:pp2)
(Just(pp1,pp2),Just(pp3,pp4))
-> Just(Ast "call" [Avar "and",pp1,pp3],pp2++pp4)
splitSqlPredicate tables pred
| sqlPredicate tables pred
= Just(pred,[])
splitSqlPredicate tables pred = Nothing
is_constant :: Ast -> Bool
is_constant (Astring _) = True
is_constant (Aint _) = True
is_constant (Afloat _) = True
is_constant _ = False
predicates :: Ast -> [Ast] -> Ast
predicates e [] = e
predicates e preds = Ast "step" (Avar "self":Astring "*":e:preds)
-- Normalization
normalize :: Ast -> Bool -> Int -> (Ast,Bool,Int)
normalize exp changed count
= case exp of
Ast "step" (step:tag:x:preds)
| any (\p -> p==true) preds
-> let preds' = filter (\p -> p /= true) preds
in norm (Ast "step" (step:tag:x:preds'))
Ast "step" (step:tag:x:preds)
| any (\p -> p==false) preds
-> (empty,True,count)
Ast "step" [Avar "self",Astring "*",e]
-> norm e
-- path steps over constants always give ()
Ast "step" (step:tag:c:_)
| is_constant c
-> (empty,True,count)
Ast "step" (step:tag:Ast "call" [Avar "data",_]:_)
-> (empty,True,count)
Ast "step" (step:tag:Ast "call" [Avar "text",_]:_)
-> (empty,True,count)
Ast "step" (step:tag:Ast "call" [Avar "empty"]:_)
-> (empty,True,count)
-- boolean reductions
Ast "call" [Avar "and",x,y]
| x == false || y == false
-> (false,True,count)
Ast "call" [Avar "or",x,y]
| x == true && y == true
-> (true,True,count)
Ast "call" [Avar "and",Ast "call" [Avar "true"],y]
-> norm y
Ast "call" [Avar "and",x,Ast "call" [Avar "true"]]
-> norm x
Ast "call" [Avar "or",Ast "call" [Avar "false"],y]
-> norm y
Ast "call" [Avar "or",x,Ast "call" [Avar "false"]]
-> norm x
Ast "call" [Avar "not",Ast "call" [Avar "true"]]
-> (false,True,count)
Ast "call" [Avar "not",Ast "call" [Avar "false"]]
-> (true,True,count)
-- (x,()) -> x
Ast "call" [Avar "concatenate",x,Ast "call" [Avar "empty"]]
-> norm x
-- ((),x) -> x
Ast "call" [Avar "concatenate",Ast "call" [Avar "empty"],x]
-> norm x
Ast "append" ((Ast "call" [Avar "empty"]):xs)
-> norm (Ast "append" xs)
Ast "call" [Avar "=",x,y]
| x == empty && y == empty
-> (true,True,count)
Ast "call" [Avar "=",x,y]
| (x == empty && is_constant y) || (y == empty && is_constant x)
-> (false,True,count)
Ast "call" [Avar cmp,Ast "construction" [_,_,_,_,Ast "append" xs],y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> norm (orAll (map (\x -> Ast "call" [Avar cmp,x,y]) xs))
Ast "call" [Avar cmp,x,Ast "construction" [_,_,_,_,Ast "append" ys]]
| any (\(f,_) -> f==cmp) sqlComparisson
-> norm (orAll (map (\y -> Ast "call" [Avar cmp,x,y]) ys))
Ast "call" [Avar cmp,Ast "for" [v,i,s,Ast "construction" [_,_,_,_,Ast "append" xs]],y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> norm (orAll (map (\x -> Ast "call" [Avar cmp,Ast "for" [v,i,s,x],y]) xs))
Ast "call" [Avar cmp,x,Ast "for" [v,i,s,Ast "construction" [_,_,_,_,Ast "append" ys]]]
| any (\(f,_) -> f==cmp) sqlComparisson
-> norm (orAll (map (\y -> Ast "call" [Avar cmp,x,Ast "for" [v,i,s,y]]) ys))
Ast "call" [Avar cmp,Ast "call" [Avar "empty"],y]
| any (\(f,_) -> f==cmp) sqlComparisson
-> (false,True,count)
Ast "call" [Avar cmp,x,Ast "call" [Avar "empty"]]
| any (\(f,_) -> f==cmp) sqlComparisson
-> (false,True,count)
-- normalize FLWORs
Ast "for" [v,i,Ast "call" [Avar "empty"],b]
-> (empty,True,count)
Ast "for" [v,i,s,Ast "call" [Avar "empty"]]
-> (empty,True,count)
-- for $v1 in (for $v2 in s2 return b2) return b1 --> for $v2 in s2, for $v1 in b2 return b1
Ast "for" [v1,i1,Ast "for" [v2,i2,s2,b2],b1]
-> norm (Ast "for" [v2,i2,s2,Ast "for" [v1,i1,b2,b1]])
-- for $v in (x,y) return b --> (for $v in x return b,for $v in y return b)
Ast "for" [v,i@(Avar "$"),Ast "call" [Avar "concatenate",x,y],b]
-> norm (Ast "call" [Avar "concatenate",Ast "for" [v,i,x,b],Ast "for" [v,i,y,b]])
-- for $v in ... return b --> b[$v/(...)]
Ast "for" [Avar v,Avar i,e@(Ast "construction" _),b]
-> norm (if i == "$"
then subst v e b
else subst v e (subst i (Aint 1) b))
Ast "for" [Avar v,Avar i,e,b]
| is_constant e
-> norm (if i == "$"
then subst v e b
else subst v e (subst i (Aint 1) b))
-- normalize XPath steps
Ast "step" (Avar "self":Astring "*":Ast "step" (step:tag:x:preds2):preds1)
-> norm (Ast "step" (step:tag:x:preds1++preds2))
Ast "step" (step:tag:Ast "step" (Avar "self":Astring "*":x@(Ast "construction" _):preds1):preds2)
-> let npreds1 = map (substContext x) preds1
in norm (Ast "step" (step:tag:x:npreds1++preds2))
Ast "step" (step:tag:x:(Ast "step" (Avar "self":Astring "*":y:preds2)):preds1)
-> let npreds2 = map (substContext y) preds2
in norm (Ast "step" (step:tag:x:preds1++npreds2))
-- (for $v in s return b)/tag --> for $v in s return b/tag
Ast "step" (step:tag:Ast "for" [v,i,s,b]:preds)
| all (wellFormedPredicate False) preds
-> norm (Ast "for" [v,i,s,Ast "step" (step:tag:b:preds)])
-- promote well-formed predicates; but note: (x,y)[1] <> (x[1],y[1])
Ast "step" (step:tag:Ast "call" [Avar "concatenate",x,y]:preds)
| all (wellFormedPredicate False) preds
-> norm (Ast "call" [Avar "concatenate",
Ast "step" (step:tag:x:preds),
Ast "step" (step:tag:y:preds)])
-- (.........)/tag --> .........
Ast "step" [Avar "child",Astring tag,Ast "construction" [_,_,_,_,Ast "append" x]]
| taggedElement x tag /= Nothing
-> case taggedElement x tag of
Just [] -> (empty,True,count)
Just s -> norm (concatenateAll s)
Ast "step" (Avar "child":tag:Ast "construction" [ctag,_,_,al,Ast "append" x]:preds)
-> norm (Ast "step" (Avar "self":tag:concatenateAll x:preds))
Ast "step" (Avar "self":Astring tag:e@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds)
| tag /= "*"
-> if tag == ctag
then norm (Ast "step" (Avar "self":Astring "*":e:preds))
else (empty,True,count)
-- (x)//tag --> (x,x//tag)
Ast "step" (Avar "descendant_any":tags:z@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds)
-> norm (Ast "call" [Avar "concatenate",predicates z preds,
Ast "step" (Avar "descendant_any":tags:concatenateAll x:preds)])
Ast "step" (Avar "descendant":Astring tag:Ast "construction" [_,_,_,al,Ast "append" x]:preds)
-> norm (Ast "step" (Avar "descendant-or-self":Astring tag:concatenateAll x:preds))
Ast "step" (Avar "descendant-or-self":Astring tag:z@(Ast "construction" [Astring ctag,_,_,al,Ast "append" x]):preds)
-> norm (if tag == ctag || tag == "*"
then Ast "call" [Avar "concatenate",predicates z preds,
Ast "step" (Avar "descendant-or-self":Astring tag:concatenateAll x:preds)]
else Ast "step" (Avar "descendant-or-self":Astring tag:concatenateAll x:preds))
-- (x)/@A --> s
Ast "step" (Avar "attribute":Astring tag:Ast "construction" [ctag,_,_,Ast "attributes" as,x]:preds)
-> norm (predicates (findAttr tag as) preds)
-- (x)//@A --> (s,x//@A)
Ast "step" (Avar "attribute-descendant":Astring tag:Ast "construction" [ctag,_,_,Ast "attributes" as,Ast "append" x]:preds)
-> norm (Ast "call" [Avar "concatenate",predicates (findAttr tag as) preds,
Ast "step" (Avar "attribute-descendant":Astring tag:concatenateAll x:preds)])
-- SQL folding
Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),Ast "call" ((Avar "tables"):f1),pred1],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),Ast "call" ((Avar "tables"):f2),pred2],
b]]
| occurs v1 b == 0
-> norm (Ast "for" [Avar v2,Avar "$",
Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):(s1++s2)),
Ast "call" ((Avar "tables"):(f1++f2)),Ast "call" [Avar "and",pred1,pred2]],
b])
Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "tables"):tables),pred1],
Ast "step" (Avar "self":Astring "*":x:pred2)]
| splitSqlPredicate [ v | Avar v <- tables ] (andAll pred2) /= Nothing
-> let Just(pred3,pred4) = splitSqlPredicate [ v | Avar v <- tables ] (andAll pred2)
in norm (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),
Ast "call" ((Avar "tables"):tables),Ast "call" [Avar "and",pred1,pred3]],
Ast "step" (Avar "self":Astring "*":x:pred4)])
Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "tables"):tables),pred1],
Ast "step" (Avar "self":Astring "*":x:pred2)]
| occursContext x == 0 && sum (map occursContext pred2) > 0
-> norm (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "tables"):tables),pred1],
Ast "step" (Avar "self":Astring "*":x:map (substContext x) pred2)])
Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),Ast "call" ((Avar "tables"):f1),pred1],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),Ast "call" ((Avar "tables"):f2),pred2],
Ast "step" (Avar "self":Astring "*":b:predd)]]
| occurs v1 b == 0 && splitSqlPredicate [ v | Avar v <- f1 ] (andAll predd) /= Nothing
-> let Just(pred3,pred4) = splitSqlPredicate [ v | Avar v <- f1 ] (andAll predd)
in norm (Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),
Ast "call" ((Avar "tables"):f1),Ast "call" [Avar "and",pred1,pred3]],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),
Ast "call" ((Avar "tables"):f2),pred2],
Ast "step" (Avar "self":Astring"*":b:pred4)]])
Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "tables"):tables),pred1],
Ast "predicate" [pred2,x]]
| splitSqlPredicate [ v | Avar v <- tables ] pred2 /= Nothing
-> let Just(pred3,pred4) = splitSqlPredicate [ v | Avar v <- tables ] pred2
in norm (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),
Ast "call" ((Avar "tables"):tables),Ast "call" [Avar "and",pred1,pred3]],
Ast "step" (Avar "self":Astring"*":x:pred4)])
Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),Ast "call" ((Avar "tables"):f1),pred1],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),Ast "call" ((Avar "tables"):f2),pred2],
Ast "predicate" [predd,b]]]
| occurs v1 b == 0 && splitSqlPredicate [ v | Avar v <- f1 ] predd /= Nothing
-> let Just(pred3,pred4) = splitSqlPredicate [ v | Avar v <- f1 ] predd
in norm (Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),
Ast "call" ((Avar "tables"):f1),Ast "call" [Avar "and",pred1,pred3]],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),
Ast "call" ((Avar "tables"):f2),pred2],
Ast "step" (Avar "self":Astring"*":b:pred4)]])
-- ignore children from insertion destination
Ast "destination" [Ast "for" [v,i,Ast "call" (Avar "SQL":sql),body]]
-> norm (Ast "for" [v,i,Ast "call" (Avar "SQL":sql),Ast "destination" [body]])
Ast "destination" [Ast "construction" [t,id,p,al,_]]
-> norm (Ast "construction" [t,id,p,al,Ast "append" []])
Ast "destination" [Ast f args]
-> norm (Ast f args)
-- default
Ast n args
-> let (r,b,c) = foldr (\a (r,b,c) -> let (x,s,i) = normalize a b c in (x:r,s,i))
([],changed,count) args
in (Ast n r,b,c)
_ -> (exp,changed,count)
where --norm e = trace ("*** "++pp exp 4++"\n "++pp e 4) (normalize e True count)
norm e = normalize e True count
pp (Ast _ _) 0 = "."
pp (Ast nm (t:ts)) n = nm ++ "(" ++ pp t (n-1) ++ concatMap (\x -> "," ++ pp x (n-1)) ts ++ ")"
pp x n = show x
foldSQL :: Ast -> Ast
foldSQL e
= case e of
Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" [Avar "select"],
Ast "call" ((Avar "tables"):tables),pred],body]
| any (\(Avar x) -> x==v) tables
-> foldSQL (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" [Avar "select",Avar (v++".*")],
Ast "call" ((Avar "tables"):tables),pred],body])
Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):cols),Ast "call" ((Avar "tables"):tables),pred]
-> let (sql,args) = makeSQL [] tables pred cols
in Ast "call" [Avar "sql",Astring sql,concatenateAll args]
Ast n args -> Ast n (map foldSQL args)
_ -> e
optimizeLoop :: Ast -> Int -> (Ast,Int)
optimizeLoop e c = let (ne,b,c') = normalize e False c
in if b
then optimizeLoop ne c'
else (ne,c)
optimize :: Ast -> Ast
optimize e = foldSQL (fst (optimizeLoop (simplify e) 0))