{-------------------------------------------------------------------------------------
-
- 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: 05/01/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 XQueryOptimizer(optimize) where

import XQueryParser(Ast(..))
import XTree


paths = [ "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]) []


-- 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 "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 step _):_))
    | elem step paths = []
tagged_children context (Ast _ xs) = concatMap (tagged_children context) xs
tagged_children _ _ = []


optimize :: Ast -> Ast
-- must be done bottom-up:    /../..
optimize (Ast "step" [Ast "parent_step" [Ast "step" [Ast "parent_step" x]]])
    = let nx = optimize (Ast "step" [Ast "parent_step" x])
      in optimize (Ast "step" [Ast "parent_step" [nx]])
-- get rid of a parent step
optimize (Ast "step" [Ast "parent_step" [x]])
    = let (nx,cond,_,_) = removeParent x
      in Ast "predicate" [optimize nx,optimize cond]
-- remove $var/.. in a let-FLWOR
optimize (Ast "let" [Avar var,source,body])
    | parentOfVar body var
    = let (nx,cond,childp,tag) = removeParent source
      in optimize (Ast "let" [Avar (var++"_parent"),Ast "predicate" [nx,cond],
                              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
optimize (Ast "for" [Avar var,Avar "$",source,body])
    | parentOfVar body var
    = let (nx,cond,childp,tag) = removeParent source
      in optimize (Ast "for" [Avar (var++"_parent"),Avar "$",Ast "predicate" [nx,cond],
                              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
optimize (Ast "element_construction" [tag,content])
    = let (nc,attrs) = collect_attributes content
      in optimize (Ast "construction" [tag,Ast "attributes" attrs,nc])
-- if //* collect all children tagnames to use descendant_any_with_tagged_children
optimize (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 optimize (Ast "for" [Avar var,i,Ast "step" [Ast "step" ((Ast "descendant_any" (path:tags)):preds)],body])
optimize (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 optimize (Ast "step" ((Ast "child_step" [Astring tag,Ast "step" ((Ast "descendant_any" (path:tags)):preds)]):preds2))
optimize (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 optimize (Ast "step" ((Ast "descendant_any" (path:tags)):preds))
-- needs more rules
optimize (Ast n args) = Ast n (map optimize args)
optimize e = e