HXQ-0.8.3: XML/HXQ/Optimizer.hs
{-------------------------------------------------------------------------------------
-
- 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: 06/10/08
-
- 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 XML.HXQ.Optimizer(optimize) where
import System.IO.Unsafe
import Control.Monad
import Char(toLower)
import List(sortBy)
import Database.HDBC
import HXML(AttList)
import XML.HXQ.Parser
import XML.HXQ.XTree
import XML.HXQ.DB
import XML.HXQ.DBConnect
paths = [ "current_step", "child_step", "descendant_step", "attribute_step", "attribute_descendant_step" ]
distinct :: Eq a => [a] -> [a]
distinct = foldl (\r a -> if elem a r then r else r++[a]) []
{-# NOINLINE publishXmlDoc #-}
-- get an XML document stored in a relational database
publishXmlDoc :: FilePath -> String -> Ast
publishXmlDoc filepath name
= let query = unsafePerformIO (publishWrapper filepath name)
[ast] = parse (scan query)
in ast
where publishWrapper filepath name
= do let prefix = map toLower name
db <- connect filepath
table <- findSchema db prefix
let query = publishTable table
disconnect db
return query
-- 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" (e:es))
= let (ce,ae) = collect_attributes e
in (Ast "step" (ce:es),ae)
collect_attributes e = (e,[])
-- does the expression contain a $var/.. ?
parentOfVar :: Ast -> String -> Bool
parentOfVar (Ast "step" [Ast "parent_step" [Ast "step" [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" [Ast "parent_step" [Ast "step" [Avar x]]]) var nvar
| x == var
= 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 -> (Ast,Ast,Bool,Ast)
removeParent (Ast "predicate" [c,x])
= let (nx,cond,childp,tag) = removeParent x
in (Ast "predicate" [c,nx],cond,childp,tag)
removeParent (Ast "step" ((Ast "child_step" [tag,x]):preds))
= (Ast "step" ((Ast "child_step" [tag,Avar "."]):preds),x,True,tag)
removeParent (Ast "step" ((Ast "descendant_step" [tag,x]):preds))
= (Ast "step" ((Ast "child_step" [tag,Avar "."]):preds),
Ast "step" ((Ast "descendant_step" [Astring "*",x]):preds),True,tag)
removeParent (Ast "step" ((Ast "attribute_step" [tag,x]):preds))
= (Ast "step" ((Ast "attribute_step" [tag,Avar "."]):preds),x,False,tag)
removeParent (Ast "step" ((Ast "descendant_attribute_step" [tag,x]):preds))
= (Ast "step" ((Ast "attribute_step" [tag,Avar "."]):preds),
Ast "step" ((Ast "descendant_step" [Astring "*",x]):preds),False,tag)
removeParent (Ast "step" (x:xs))
= let (nx,cond,childp,tag) = removeParent x
in (Ast "step" (nx:xs),cond,childp,tag)
removeParent e = error ("Cannot remove this parent step "++(show e))
tagged_children :: String -> Ast -> [Tag]
tagged_children context (Ast "step" ((Ast "child_step" [Astring tag,Avar "."]):_))
| context == "."
= [tag]
tagged_children context (Ast "step" ((Ast "child_step" [Astring tag,Ast "step" ((Avar v):_)]):_))
| v == context
= [tag]
tagged_children _ (Ast "step" ((Ast "descendant_any" _):_)) = []
tagged_children _ (Ast "step" ((Ast step _):_))
| elem step paths = []
tagged_children context (Ast _ xs) = concatMap (tagged_children context) xs
tagged_children _ _ = []
empty = Ast "call" [Avar "empty"]
simplify :: Ast -> Ast
-- must be done bottom-up: /../..
simplify (Ast "step" [Ast "parent_step" [Ast "step" [Ast "parent_step" x]]])
= let nx = simplify (Ast "step" [Ast "parent_step" x])
in simplify (Ast "step" [Ast "parent_step" [nx]])
-- get rid of a parent step
simplify (Ast "step" [Ast "parent_step" [x]])
= let (cond,nx,_,_) = removeParent x
in Ast "predicate" [simplify cond,simplify nx]
-- remove $var/.. in a let-FLWOR
simplify (Ast "let" [Avar var,source,body])
| parentOfVar body var
= let (cond,nx,childp,tag) = removeParent source
in simplify (Ast "let" [Avar (var++"_parent"),Ast "predicate" [cond,nx],
Ast "let" [Avar var,
Ast "step" [ Ast (if childp
then "child_step"
else "attribute_step")
[tag,Avar (var++"_parent")] ],
replaceParentOfVar body var (var++"_parent")]])
-- remove $var/.. from a for-FLWOR
simplify (Ast "for" [Avar var,Avar "$",source,body])
| parentOfVar body var
= let (cond,nx,childp,tag) = removeParent source
in simplify (Ast "for" [Avar (var++"_parent"),Avar "$",Ast "predicate" [cond,nx],
Ast "for" [Avar var,Avar "$",
Ast "step" [ Ast (if childp
then "child_step"
else "attribute_step")
[tag,Avar (var++"_parent")] ],
replaceParentOfVar body var (var++"_parent")]])
-- pull out attributes from a general element construction
simplify (Ast "element_construction" [tag,Ast "attributes" as,content])
= let (nc,attrs) = collect_attributes content
in simplify (Ast "construction" [tag,Ast "attributes" (as++attrs),nc])
-- if //* collect all children tagnames to use descendant_any_with_tagged_children
simplify (Ast "for" [Avar var,i,Ast "step" [Ast "step" ((Ast "descendant_step" [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 = map Avar ctags
in simplify (Ast "for" [Avar var,i,Ast "step" [Ast "step" ((Ast "descendant_any" (path:tags)):preds)],body])
simplify (Ast "step" ((Ast "child_step" [Astring tag,Ast "step" ((Ast "descendant_step" [Astring "*",path]):preds)]):preds2))
= let ctags = distinct(tag:(concatMap (tagged_children ".") preds))
tags = map Avar ctags
in simplify (Ast "step" ((Ast "child_step" [Astring tag,Ast "step" ((Ast "descendant_any" (path:tags)):preds)]):preds2))
simplify (Ast "step" ((Ast "descendant_step" [Astring "*",path]):preds))
| any (not . null . (tagged_children ".")) preds
= let ctags = distinct (concatMap (tagged_children ".") preds)
tags = map Avar ctags
in simplify (Ast "step" ((Ast "descendant_any" (path:tags)):preds))
-- expand the wrapper of a stored document
simplify (Ast "call" [Avar "publish",Astring dbpath,Astring name])
= simplify (publishXmlDoc dbpath name)
-- default
simplify (Ast n args) = Ast n (map simplify args)
simplify e = e
taggedElement :: [Ast] -> String -> Maybe [Ast]
taggedElement (e@(Ast "construction" [Astring ctag,_,x]):xs) tag
| ctag == tag || tag == "*"
= case taggedElement xs tag of
Nothing -> Nothing
Just s -> Just (e:s)
taggedElement ((Ast "construction" [_,_,_]):xs) tag
= taggedElement xs tag
taggedElement ((Ast "call" [Avar "concatenate",x,y]):xs) tag
= case (taggedElement (x:xs) tag,taggedElement (y:xs) tag) of
(Just tx,Just ty) -> Just (tx++ty)
_ -> Nothing
taggedElement ((Astring _):xs) tag
= taggedElement xs tag
taggedElement ((Aint _):xs) tag
= taggedElement xs tag
taggedElement (e:xs) tag = Nothing
taggedElement [] _ = Just []
findAttr :: String -> [Ast] -> Ast
findAttr tag ((Ast "pair" [Astring a,v]):_) | a==tag || tag=="*" = v
findAttr tag (_:xs) = findAttr tag xs
findAttr _ [] = empty
andAll :: [Ast] -> Ast
andAll [x] = x
andAll (x:xs) = foldl (\a r -> call "and" [a,r]) x xs
substContext :: Ast -> Ast -> Maybe Ast
substContext context e
= case e of
Ast "call" ((Avar f):xs)
-> do ys <- mapM (substContext context) xs
return (Ast "call" ((Avar f):ys))
Ast "descendant_any" (x:tags)
-> do nx <- substContext context x
return (Ast "descendant_any" (nx:tags))
Ast step [tag,x]
| elem step paths
-> do nx <- substContext context x
return (Ast step [tag,nx])
Avar "." -> Just context
Astring _ -> Just e
Aint _ -> Just e
Afloat _ -> Just e
Avar _ -> Just e
_ -> Nothing
occurs :: String -> Ast -> Int
occurs v e
= case e of
Avar w | v==w -> 1
Ast "let" [Avar w,_,_] | v==w -> 0
Ast "for" [Avar w,Avar i,_,_] | v==w || v==i -> 0
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,_,_] | v==w -> b
Ast "for" [Avar w,Avar i,_,_] | v==w || v==i -> b
Ast n xs -> Ast n (map (subst v e) xs)
_ -> b
sqlPredicate :: Ast -> Bool
sqlPredicate e
= case e of
Astring s -> True
Aint n -> True
Ast "child_step" [Astring c,Avar v] -> True
Ast "construction" [_,_,Ast "append" [x]]
-> sqlPredicate x
Ast "call" [Avar "text",x]
-> sqlPredicate x
Ast "call" [Avar cmp,x,y]
| any (\(f,_) -> f==cmp) sqlFunctions
-> (sqlPredicate x) && (sqlPredicate y)
_ -> False
usesCurrentContext :: Ast -> Bool
usesCurrentContext (Ast _ xs) = any usesCurrentContext xs
usesCurrentContext (Avar ".") = True
usesCurrentContext _ = False
-- Normalization
normalize :: Ast -> Bool -> (Ast,Bool)
normalize exp changed
= case exp of
Ast "step" [x]
-> normalize x True
Ast "step" (x:(Ast "call" [Avar "true"]):xs)
-> normalize (Ast "step" (x:xs)) True
Ast "step" (x:(Ast "call" [Avar "false"]):xs)
-> (empty,True)
Ast "for" [v,i,Ast "call" [Avar "empty"],b]
-> (empty,True)
Ast "for" [v,i,s,Ast "call" [Avar "empty"]]
-> (empty,True)
Ast "descendant_any" ((Astring _):_)
-> (empty,True)
Ast "descendant_any" ((Aint _):_)
-> (empty,True)
Ast "descendant_any" ((Afloat _):_)
-> (empty,True)
Ast "descendant_any" ((Ast "call" [Avar "text",_]):_)
-> (empty,True)
Ast "descendant_any" ((Ast "call" [Avar "empty"]):_)
-> (empty,True)
Ast step [_,Astring _]
| elem step paths
-> (empty,True)
Ast step [_,Aint _]
| elem step paths
-> (empty,True)
Ast step [_,Afloat _]
| elem step paths
-> (empty,True)
Ast step [_,Ast "call" [Avar "text",_]]
| elem step paths
-> (empty,True)
Ast step [_,Ast "call" [Avar "empty"]]
| elem step paths
-> (empty,True)
Ast "call" [Avar "and",Ast "call" [Avar "true"],x]
-> normalize x True
Ast "call" [Avar "and",x,Ast "call" [Avar "true"]]
-> normalize x True
-- (x,()) -> x
Ast "call" [Avar "concatenate",x,Ast "call" [Avar "empty"]]
-> normalize x True
-- ((),x) -> x
Ast "call" [Avar "concatenate",Ast "call" [Avar "empty"],x]
-> normalize x True
-- 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]
-> normalize (Ast "for" [v2,i2,s2,Ast "for" [v1,i1,b2,b1]]) True
-- (for $v in s return b)/tag --> for $v in s return b/tag -->
Ast "descendant_any" ((Ast "for" [v,i,s,b]):tags)
-> normalize (Ast "for" [v,i,s,Ast "descendant_any" (b:tags)]) True
Ast step [tag,Ast "for" [v,i,s,b]]
| elem step paths
-> normalize (Ast "for" [v,i,s,Ast step [tag,b]]) True
-- (x,y)/tag --> (x/tag,y/tag)
Ast "descendant_any" ((Ast "call" [Avar "concatenate",x,y]):tags)
-> normalize (Ast "call" [Avar "concatenate",Ast "descendant_any" (x:tags),Ast "descendant_any" (y:tags)]) True
Ast step [tag,Ast "call" [Avar "concatenate",x,y]]
| elem step paths
-> normalize (Ast "call" [Avar "concatenate",Ast step [tag,x],Ast step [tag,y]]) True
-- for $v in (x,y) return b --> (for $v in x return b,for $v in y return b)
Ast "for" [v,i,Ast "call" [Avar "concatenate",x,y],b]
-> normalize (Ast "call" [Avar "concatenate",Ast "for" [v,i,x,b],Ast "for" [v,i,y,b]]) True
Ast "for" [Avar v,Avar i,e,b]
| case e of Ast "construction" _ -> True; Ast _ _ -> False; _ -> True
-> normalize (if i == "$"
then subst v e b
else subst v e (subst i (Aint 1) b)) True
-- unfold linear let
Ast "let" [Avar v,e,b]
| occurs v b < 2
-> normalize (subst v e b) True
-- (if c then t else e)/A --> if c then t/A else e/A
Ast "descendant_any" ((Ast "predicate" [c,e]):tags)
| not (usesCurrentContext c)
-> normalize (Ast "predicate" [c,Ast "descendant_any" (e:tags)]) True
Ast step [tag,Ast "predicate" [c,e]]
| elem step paths && not (usesCurrentContext c)
-> normalize (Ast "predicate" [c,Ast step [tag,e]]) True
-- normalize predicate
Ast "predicate" [Ast "call"[Avar "true"],x]
-> (empty,True)
Ast "predicate" [x,Ast "call"[Avar "empty"]]
-> (empty,True)
Ast "step" ((Ast "call" [Avar "empty"]):xs)
-> (empty,True)
Ast "step" ((Ast "call" [Avar "concatenate",x,y]):xs)
-> normalize (Ast "call" [Avar "concatenate",Ast "step" (x:xs),Ast "step" (y:xs)]) True
Ast "step" ((Ast "for" [v,i,s,b]):xs)
-> normalize (Ast "for" [v,i,s,Ast "step" (b:xs)]) True
Ast "step" (e@(Ast "construction" [_,_,_]):xs)
-> case mapM (substContext e) xs of
Just es -> normalize (Ast "predicate" [andAll es,e]) True
Nothing -> let (r,b) = foldr (\a (r,b) -> let (c,s) = normalize a b in (c:r,s))
([],changed) (e:xs)
in (Ast "step" r,b)
Ast "call" [Avar "=",x,y]
| x == empty || y == empty
-> (Ast "call"[Avar "true"],True)
-- (<ctag>...<tag>...</tag>...</ctag>)/tag --> ...<tag>...</tag>...
Ast "child_step" [Astring tag,Ast "construction" [_,_,Ast "append" x]]
| taggedElement x tag /= Nothing
-> case taggedElement x tag of
Just [] -> (empty,True)
Just s -> normalize (concatenateAll s) True
Ast "child_step" [Astring tag,Ast "construction" [_,_,Ast "append" x]]
-> normalize (Ast "current_step" [Astring tag,concatenateAll x]) True
Ast "current_step" [Astring tag1,e@(Ast "construction" [Astring tag2,_,Ast "append" x])]
-> if tag1 == tag2 || tag1 == "*"
then normalize e True
else (empty,True)
-- (<tag>x</tag>)//tag --> (x,x//tag)
Ast "descendant_any" (z@(Ast "construction" [Astring ctag,_,Ast "append" x]):tags)
-> normalize (Ast "call" [Avar "concatenate",z,Ast "descendant_any" ((concatenateAll x):tags)]) True
Ast "descendant_step" [Astring tag,z@(Ast "construction" [Astring ctag,_,Ast "append" x])]
-> normalize (if tag == ctag || tag == "*"
then Ast "call" [Avar "concatenate",z,Ast "descendant_step" [Astring tag,concatenateAll x]]
else Ast "descendant_step" [Astring tag,concatenateAll x]) True
-- (<tag A=s>x</tag>)/@A --> s
Ast "attribute_step" [Astring tag,Ast "construction" [ctag,Ast "attributes" as,x]]
-> (findAttr tag as,True)
-- (<tag A=s>x</tag>)//@A --> (s,x//@A)
Ast "attribute_descendant_step" [Astring tag,Ast "construction" [ctag,Ast "attributes" as,Ast "append" x]]
-> normalize (Ast "call" [Avar "concatenate",findAttr tag as,
Ast "attribute_descendant_step" [Astring tag,concatenateAll x]]) True
-- SQL folding
Ast "for" [Avar v1,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s1),Ast "call" ((Avar "from"):f1),pred1],
Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),Ast "call" ((Avar "from"):f2),pred2],b]]
-> normalize (Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):(s1++s2)),
Ast "call" ((Avar "from"):(f1++f2)),Ast "call" [Avar "and",pred1,pred2]],b])
True
Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "from"):f),pred1],
Ast "predicate" [pred2,x]]
| sqlPredicate pred2
-> normalize (Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),
Ast "call" ((Avar "from"):f),Ast "call" [Avar "and",pred1,pred2]],x]) True
-- default
Ast n args
-> let (r,b) = foldr (\a (r,b) -> let (c,s) = normalize a b in (c:r,s)) ([],changed) args
in (Ast n r,b)
_ -> (exp,changed)
foldSQL :: Ast -> Ast
foldSQL e
= case e of
Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):cols),Ast "call" ((Avar "from"):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 -> Ast
optimizeLoop e = let (ne,b) = normalize e False
in if b
then optimizeLoop ne
else ne
optimize :: Ast -> Ast
optimize e = foldSQL (optimizeLoop (simplify e))