diff --git a/HXQ-unstable.hs b/HXQ-unstable.hs --- a/HXQ-unstable.hs +++ b/HXQ-unstable.hs @@ -21,7 +21,7 @@ import XML.HXQ.Interpreter(evalInput) -version = "0.8.3" +version = "0.8.4" default_system_path = "/usr/local/lib/ghc-6.8.2" default_hxq_path = "./" diff --git a/HXQ.cabal b/HXQ.cabal --- a/HXQ.cabal +++ b/HXQ.cabal @@ -1,6 +1,6 @@ Cabal-Version: >= 1.2 Name: HXQ -Version: 0.8.3 +Version: 0.8.4 Synopsis: A Compiler from XQuery to Haskell Description: HXQ is a fast and space-efficient compiler from XQuery (the standard @@ -23,6 +23,7 @@ Test1.hs Test2.hs TestDB.hs + TestDB2.hs compile data-files: index.html diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -2,7 +2,7 @@ - - The main program of the XQuery interpreter - Programmer: Leonidas Fegaras (fegaras@cse.uta.edu) -- Date: 06/10/2008 +- Date: 06/26/2008 - ---------------------------------------------------------------} @@ -15,7 +15,7 @@ import XML.HXQ.Interpreter(evalInput,xqueryE) import XML.HXQ.XQuery -version = "0.8.3" +version = "0.8.4" parseEnv :: [String] -> [(String,String)] @@ -37,7 +37,8 @@ Just dbname = lookup "db" env verbose = case lookup "v" env of Nothing -> False; _ -> True case lookup "help" env of - Just _ -> do putStrLn "Command line options and files:" + Just _ -> do putStrLn ("HXQ: XQuery Interpreter version "++version++".") + putStrLn "Command line options and files:" putStrLn " xquery-file interpret the XQuery in xquery-file" putStrLn " -db file-path use the relational database in file-path during querying" putStrLn " -c xquery-file compile the XQuery in xquery-file into Haskell code" diff --git a/TestDB2.hs b/TestDB2.hs new file mode 100644 --- /dev/null +++ b/TestDB2.hs @@ -0,0 +1,23 @@ +{-------------------------------------------------------------- +- +- A main program to test XML shredding and publishing +- +- Programmer: Leonidas Fegaras (fegaras@cse.uta.edu) +- Date: 06/12/2008 +- +---------------------------------------------------------------} + +{-# OPTIONS_GHC -fth #-} + +module Main where + +import XML.HXQ.XQuery + + +main = do db <- connect "myDB" + -- Before compilation, you do: shred db "data/cs.xml" "c" + res <- $(xqdb (" for $s in publish('myDB','c')//gradstudent " + ++ " where $s//lastname='Galanis' " + ++ " return $s//gpa ")) db + putXSeq res + disconnect db diff --git a/XML/HXQ/Compiler.hs b/XML/HXQ/Compiler.hs --- a/XML/HXQ/Compiler.hs +++ b/XML/HXQ/Compiler.hs @@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/ -- Creation: 02/15/08, last update: 06/02/08 +- Creation: 02/15/08, last update: 06/21/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. @@ -39,7 +39,7 @@ current_step :: Tag -> XTree -> XSeq current_step m x = case x of - XElem k _ _ _ | (k==m || m=="*") -> [x] + XElem k _ _ _ _ | (k==m || m=="*") -> [x] _ -> [] @@ -47,32 +47,32 @@ child_step :: Tag -> XTree -> XSeq child_step m x = case x of - XElem _ _ _ bs + XElem _ _ _ _ bs -> foldr (\b s -> case b of - XElem k _ _ _ | (k==m || m=="*") -> b:s + XElem k _ _ _ _ | (k==m || m=="*") -> b:s _ -> s) [] bs _ -> [] -- XPath step //tag or //* descendant_step :: Tag -> XTree -> XSeq -descendant_step m (x@(XElem t _ _ cs)) +descendant_step m (x@(XElem t _ _ _ cs)) | m==t || m=="*" = x:(concatMap (descendant_step m) cs) -descendant_step m (XElem t _ _ cs) = concatMap (descendant_step m) cs +descendant_step m (XElem t _ _ _ cs) = concatMap (descendant_step m) cs descendant_step m _ = [] -- It's like //* but has tagged children, which are derived statically -- After examing 100 children it gives up: this avoids space leaks descendant_any_with_tagged_children :: [Tag] -> XTree -> XSeq -descendant_any_with_tagged_children tags (x@(XElem t _ _ cs)) +descendant_any_with_tagged_children tags (x@(XElem t _ _ _ cs)) | all (\tag -> foldr (\b s -> case b of - (XElem k _ _ _) -> s || k == tag + (XElem k _ _ _ _) -> s || k == tag _ -> s) False cs100) tags = x:(concatMap (descendant_any_with_tagged_children tags) cs) where cs100 = take 100 cs -descendant_any_with_tagged_children tags (XElem t _ _ cs) +descendant_any_with_tagged_children tags (XElem t _ _ _ cs) = concatMap (descendant_any_with_tagged_children tags) cs descendant_any_with_tagged_children tags _ = [] @@ -81,15 +81,15 @@ attribute_step :: Tag -> XTree -> XSeq attribute_step m x = case x of - (XElem _ al _ _) -> foldr (\(k,v) s -> if k==m || m=="*" - then (XText v):s - else s) [] al + (XElem _ al _ _ _) -> foldr (\(k,v) s -> if k==m || m=="*" + then (XText v):s + else s) [] al _ -> [] -- XPath step //@attr or //@* attribute_descendant_step :: Tag -> XTree -> XSeq -attribute_descendant_step m (x@(XElem _ al _ cs)) +attribute_descendant_step m (x@(XElem _ al _ _ cs)) = foldr (\(k,v) s -> if k==m || m=="*" then (XText v):s else s) @@ -97,6 +97,12 @@ attribute_descendant_step m _ = [] +-- NOT USED: XPath step /.. +parent_step :: Tag -> XTree -> XSeq +parent_step _ (XElem _ _ _ p _) = [p] +parent_step _ e = error ("Cannot derive the parent of "++show e) + + {------------ Functions --------------------------------------------------------------} @@ -134,8 +140,9 @@ text :: XSeq -> XSeq text xs = foldr (\x r -> case x of - XElem _ _ _ zs -> (filter (\a -> case a of XText _ -> True; XInt _ -> True; - XFloat _ -> True; XBool _ -> True; _ -> False) zs)++r + XElem _ _ _ _ zs + -> (filter (\a -> case a of XText _ -> True; XInt _ -> True; + XFloat _ -> True; XBool _ -> True; _ -> False) zs)++r XText _ -> x:r XInt _ -> x:r XFloat _ -> x:r @@ -204,8 +211,8 @@ compareXTrees :: XTree -> XTree -> Ordering -compareXTrees (XElem _ _ _ _) _ = EQ -compareXTrees _ (XElem _ _ _ _) = EQ +compareXTrees (XElem _ _ _ _ _) _ = EQ +compareXTrees _ (XElem _ _ _ _ _) = EQ compareXTrees (XInt n) (XInt m) = compare n m compareXTrees (XFloat n) (XInt m) = compare n (fromIntegral m) compareXTrees (XInt n) (XFloat m) = compare (fromIntegral n) m @@ -222,9 +229,9 @@ strictCompareOne x y = error ("Illegal operands in strict comparison: "++(show x)++" "++(show y)) strictCompare :: XSeq -> XSeq -> Ordering -strictCompare [XElem _ _ _ x] [XElem _ _ _ y] = strictCompareOne x y -strictCompare x [XElem _ _ _ y] = strictCompareOne x y -strictCompare [XElem _ _ _ x] y = strictCompareOne x y +strictCompare [XElem _ _ _ _ x] [XElem _ _ _ _ y] = strictCompareOne x y +strictCompare x [XElem _ _ _ _ y] = strictCompareOne x y +strictCompare [XElem _ _ _ _ x] y = strictCompareOne x y strictCompare x y = strictCompareOne x y compareXSeqs :: Bool -> XSeq -> XSeq -> Ordering @@ -257,7 +264,8 @@ ( "child_step", [| child_step |] ), ( "descendant_step", [| descendant_step |] ), ( "attribute_step", [| attribute_step |] ), - ( "attribute_descendant_step", [| attribute_descendant_step |] ) + ( "attribute_descendant_step", [| attribute_descendant_step |] ), + ( "parent_step", [| parent_step |] ) ] @@ -280,9 +288,9 @@ ( "gt", 2, \[xs,ys] -> [| if strictCompare $xs $ys == GT then [trueXT] else [falseXT] |] ), ( "le", 2, \[xs,ys] -> [| if strictCompare $xs $ys `elem` [LT,EQ] then [trueXT] else [falseXT] |] ), ( "ge", 2, \[xs,ys] -> [| if strictCompare $xs $ys `elem` [GT,EQ] then [trueXT] else [falseXT] |] ), - ( "<<", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ <- $xs, XElem _ _ oy _ <- $ys, ox < oy ] |] ), - ( ">>", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ <- $xs, XElem _ _ oy _ <- $ys, ox > oy ] |] ), - ( "is", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ <- $xs, XElem _ _ oy _ <- $ys, ox == oy ] |] ), + ( "<<", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ _ <- $xs, XElem _ _ oy _ _ <- $ys, ox < oy ] |] ), + ( ">>", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ _ <- $xs, XElem _ _ oy _ _ <- $ys, ox > oy ] |] ), + ( "is", 2, \[xs,ys] -> [| [ trueXT | XElem _ _ ox _ _ <- $xs, XElem _ _ oy _ _ <- $ys, ox == oy ] |] ), ( "+", 2, \[xs,ys] -> [| [ arithmetic (+) x y | x <- toNum $xs, y <- toNum $ys ] |] ), ( "-", 2, \[xs,ys] -> [| [ arithmetic (-) x y | x <- toNum $xs, y <- toNum $ys ] |] ), ( "*", 2, \[xs,ys] -> [| [ arithmetic (*) x y | x <- toNum $xs, y <- toNum $ys ] |] ), @@ -304,15 +312,15 @@ ( "text", 1, \[xs] -> [| text $xs |] ), ( "string", 1, \[xs] -> [| text $xs |] ), ( "data", 1, \[xs] -> [| text $xs |] ), - ( "node", 1, \[xs] -> [| [ w | w@(XElem _ _ _ _) <- $xs ] |] ), + ( "node", 1, \[xs] -> [| [ w | w@(XElem _ _ _ _ _) <- $xs ] |] ), ( "exists", 1, \[xs] -> [| [ XBool (not (null $xs)) ] |] ), ( "empty", 0, \[] -> [| [] |] ), ( "true", 0, \[] -> [| [trueXT] |] ), ( "false", 0, \[] -> [| [] |] ), ( "if", 3, \[cs,ts,es] -> [| if conditionTest $cs then $ts else $es |] ), - ( "element", 2, \[tags,xs] -> [| [ x | tag <- toString $tags, x@(XElem t _ _ _) <- $xs, (t==tag || tag=="*") ] |] ), + ( "element", 2, \[tags,xs] -> [| [ x | tag <- toString $tags, x@(XElem t _ _ _ _) <- $xs, (t==tag || tag=="*") ] |] ), ( "attribute", 2, \[tags,xs] -> [| [ z | tag <- toString $tags, x <- $xs, z <- attribute_step tag x ] |] ), - ( "name", 1, \[xs] -> [| [ XText tag | XElem tag _ _ _ <- $xs ] |] ), + ( "name", 1, \[xs] -> [| [ XText tag | XElem tag _ _ _ _ <- $xs ] |] ), ( "contains", 2, \[xs,text] -> [| [ trueXT | x <- toString $xs, t <- toString $text, contains x t ] |] ), ( "substring", 3, \[xs,n1,n2] -> [| [ XText (take m2 (drop (m1-1) x)) | x <- toString $xs, XInt m1 <- toNum $n1, XInt m2 <- toNum $n2 ] |] ), @@ -367,7 +375,7 @@ -- does the expression contain a last()? containsLast :: Ast -> Bool -containsLast (Ast "step" [Ast "call" [Avar "last"]]) = True +containsLast (Ast "call" [Avar "last"]) = True containsLast (Ast f _) | elem f ["let","for","predicate"] = False containsLast (Ast "step" _) = False containsLast (Ast _ args) = or (map containsLast args) @@ -378,10 +386,10 @@ maxPosition :: Ast -> Ast -> Int maxPosition position e = case e of - Ast "call" [Avar f,Ast "step" [p],Aint n] + Ast "call" [Avar f,p,Aint n] | f `elem` ["=","<","<=","eq","lt","le"] && p == position -> n - Ast "call" [Avar f,Aint n,Ast "step" [p]] + Ast "call" [Avar f,Aint n,p] | f `elem` ["=",">",">=","eq","gt","ge"] && p == position -> n Ast "let" [Avar x,source,body] @@ -403,6 +411,9 @@ pathPosition = Ast "call" [Avar "position"] +parent_error = error "constructed elements have no parent" + + -- extract the QName qName :: XSeq -> Tag qName [XText s] = s @@ -485,8 +496,6 @@ -> let bc = compile body context position last effective_axis tc = litE (stringL tag) in [| foldr (\x r -> ($(findV path_step paths) $tc x)++r) [] $bc |] - Ast "step" [exp] - -> compile exp context position last effective_axis Ast "step" (exp:predicates) -> compilePredicates predicates (compile exp context position last effective_axis) True Ast "predicate" [condition,body] @@ -498,7 +507,7 @@ Ast "construction" [Astring tag,Ast "attributes" [],body] -> let ct = litE (StringL tag) bc = compile body context position last effective_axis - in [| [ XElem $ct [] 0 $bc ] |] + in [| [ XElem $ct [] 0 parent_error $bc ] |] Ast "construction" [tag,Ast "attributes" al,body] -> let alc = foldr (\(Ast "pair" [a,v]) r -> let ac = compile a context position last effective_axis @@ -506,7 +515,7 @@ in [| (qName $ac,showXS $vc) : $r |]) [| [] |] al ct = compile tag context position last effective_axis bc = compile body context position last effective_axis - in [| [ XElem (qName $ct) $alc 0 $bc ] |] + in [| [ XElem (qName $ct) $alc 0 parent_error $bc ] |] Ast "let" [Avar var,source,body] -> do s <- compile source context position last effective_axis b <- compile body context position last effective_axis @@ -631,8 +640,6 @@ tc = litE (stringL tag) in [| do vs <- $bc return (foldr (\x r -> ($(findV path_step paths) $tc x)++r) [] vs) |] - Ast "step" [exp] - -> compileM exp context position last effective_axis Ast "step" (exp:predicates) -> [| do vs <- $(compileM exp context position last effective_axis) $(compilePredicatesM predicates [| vs |] True) |] @@ -654,7 +661,7 @@ -> let ct = litE (StringL tag) bc = compileM body context position last effective_axis in [| do b <- $bc - return [ XElem $ct [] 0 b ] |] + return [ XElem $ct [] 0 parent_error b ] |] Ast "construction" [tag,Ast "attributes" al,body] -> let alc = foldr (\(Ast "pair" [a,v]) r -> [| do ac <- $(compileM a context position last effective_axis) @@ -666,7 +673,7 @@ in [| do a <- $alc c <- $ct b <- $bc - return [ XElem (qName c) a 0 b ] |] + return [ XElem (qName c) a 0 parent_error b ] |] Ast "let" [Avar var,source,body] -> [| $(compileM source context position last effective_axis) >>= $(lamE [varP (mkName var)] (compileM body context position last effective_axis)) |] diff --git a/XML/HXQ/DB.hs b/XML/HXQ/DB.hs --- a/XML/HXQ/DB.hs +++ b/XML/HXQ/DB.hs @@ -51,15 +51,18 @@ XInt n -> SqlInteger (toInteger n) XFloat n -> SqlString (show n) XBool n -> SqlBool n - XElem n _ _ [x] -> xml2sql x + XElem n _ _ _ [x] -> xml2sql x _ -> error ("Cannot convert "++show e++" into sql") +perror = error "constructed elements have no parent" + + executeSQL :: Statement -> XSeq -> IO XSeq executeSQL stmt args = do n <- handleSqlError (execute stmt (map xml2sql args)) result <- handleSqlError (fetchAllRowsAL stmt) - return (map (\x -> XElem "row" [] 0 (map (\(s,v) -> XElem s [] 0 [sql2xml v]) x)) result) + return (map (\x -> XElem "row" [] 0 perror (map (\(s,v) -> XElem s [] 0 perror [sql2xml v]) x)) result) prepareSQL :: (IConnection conn) => conn -> String -> IO Statement @@ -378,33 +381,89 @@ publishTable table = "{" ++ publishS table "error" ++ "}" -sqlFunctions = [("=","="),("eq","="),("<=","<="),(">=",">="),("!=","!="),(">",">"), - ("<","<"),("ne","!="),("gt",">"),("lt","<"),("ge",">="),("le","<="), - ("and","and"),("or","or")] +sqlComparisson = [("=","="),("eq","="),("<=","<="),(">=",">="),("!=","!="),(">",">"), + ("<","<"),("ne","!="),("gt",">"),("lt","<"),("ge",">="),("le","<=")] +sqlBoolean = [("and","and"),("or","or")] + + +-- Is this an SQL predicate? +sqlPredicate :: [String] -> Ast -> Bool +sqlPredicate tables e + = case e of + Ast "child_step" [Astring c,Avar v] + -> elem v tables + Ast "construction" [_,_,Ast "append" [x]] + -> sqlPredicate tables x + Ast "call" [Avar "text",x] + -> sqlPredicate tables x + Ast "call" [Avar cmp,x,y] + | any (\(f,_) -> f==cmp) sqlComparisson + -> (sqlExpr x) && (sqlExpr y) + Ast "call" [Avar cmp,x,y] + | any (\(f,_) -> f==cmp) sqlBoolean + -> (sqlPredicate tables x) && (sqlPredicate tables y) + _ -> False + where sqlExpr e + = case e of + Astring s -> True + Aint n -> True + Ast "child_step" [Astring c,Avar v] + -> elem v tables + Ast "construction" [_,_,Ast "append" [x]] + -> sqlExpr x + Ast "call" [Avar "text",x] + -> sqlExpr x + _ -> False + + -- Convert a predicate AST to an SQL predicate that uses the tables -toSQL :: [String] -> Ast -> (String,[Ast]) -toSQL tables e +predToSQL :: [String] -> Ast -> (String,[Ast]) +predToSQL tables e = case e of - Astring s -> ("\'"++s++"\'",[]) - Aint n -> (show n,[]) Ast "child_step" [Astring c,Avar v] -> if elem v tables - then (v++"."++c,[]) - else ("?",[e]) + then ("",[]) + else error ("Cannot convert to an SQL predicate: "++show e) Ast "construction" [_,_,Ast "append" [x]] - -> toSQL tables x + -> predToSQL tables x Ast "call" [Avar "text",x] - -> toSQL tables x + -> predToSQL tables x Ast "call" [Avar cmp,x,y] - | any (\(f,_) -> f==cmp) sqlFunctions - -> let (nx,vx) = toSQL tables x - (ny,vy) = toSQL tables y - in (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlFunctions)) ++ " " ++ ny,vx++vy) - _ -> error ("Cannot convert to SQL: "++show e) + | any (\(f,_) -> f==cmp) sqlComparisson + -> let (nx,vx) = expToSQL tables x + (ny,vy) = expToSQL tables y + in if nx == "" + then (ny,vx) + else if ny == "" + then (nx,vy) + else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlComparisson)) ++ " " ++ ny,vx++vy) + Ast "call" [Avar cmp,x,y] + | any (\(f,_) -> f==cmp) sqlBoolean + -> let (nx,vx) = predToSQL tables x + (ny,vy) = predToSQL tables y + in if nx == "" + then (ny,vy) + else if ny == "" + then (nx,vx) + else (nx ++ " " ++ snd (head (filter (\(f,_) -> f==cmp) sqlBoolean)) ++ " " ++ ny,vx++vy) + _ -> error ("Cannot convert to an SQL predicate: "++show e) + where expToSQL tables e + = case e of + Astring s -> ("\'"++s++"\'",[]) + Aint n -> (show n,[]) + Ast "child_step" [Astring c,Avar v] + -> if elem v tables + then (v++"."++c,[]) + else ("?",[e]) + Ast "construction" [_,_,Ast "append" [x]] + -> expToSQL tables x + Ast "call" [Avar "text",x] + -> expToSQL tables x + _ -> ("?",[e]) --- Convert an AST to an SQL +-- Convert an AST to an SQL query makeSQL :: [Ast] -> Ast -> [Ast] -> (String,[Ast]) makeSQL tables pred cols = let tnames = [ x | Avar x <- tables ] @@ -420,7 +479,7 @@ then (if null cs then "select * from "++ts else "select "++cs++" from "++ts,[]) - else let (p,args) = toSQL tnames pred + else let (p,args) = predToSQL tnames pred in (if null cs then "select * from "++ts++" where "++p else "select "++cs++" from "++ts++" where "++p,args) diff --git a/XML/HXQ/Interpreter.hs b/XML/HXQ/Interpreter.hs --- a/XML/HXQ/Interpreter.hs +++ b/XML/HXQ/Interpreter.hs @@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/ -- Creation: 03/22/08, last update: 05/30/08 +- Creation: 03/22/08, last update: 06/21/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. @@ -119,8 +119,6 @@ | memV path_step pathFunctions -> foldr (\x r -> ((findV path_step pathFunctions) tag x)++r) [] (eval body context position last effective_axis env fncs) - Ast "step" [exp] - -> eval exp context position last effective_axis env fncs Ast "step" (exp:predicates) -> applyPredicates predicates (eval exp context position last effective_axis env fncs) True env fncs Ast "predicate" [condition,body] @@ -140,7 +138,7 @@ else error ("Wrong number of arguments in function call: "++fname) _ -> error ("Undefined function: "++fname) Ast "construction" [Astring tag,Ast "attributes" [],body] - -> [ XElem tag [] 0 (eval body context position last effective_axis env fncs) ] + -> [ XElem tag [] 0 parent_error (eval body context position last effective_axis env fncs) ] Ast "construction" [tag,Ast "attributes" al,body] -> let alc = map (\(Ast "pair" [a,v]) -> let ac = eval a context position last effective_axis env fncs @@ -148,7 +146,7 @@ in (qName ac,showXS vc)) al ct = eval tag context position last effective_axis env fncs bc = eval body context position last effective_axis env fncs - in [ XElem (qName ct) alc 0 bc ] + in [ XElem (qName ct) alc 0 parent_error bc ] Ast "let" [Avar var,source,body] -> eval body context position last effective_axis ((var,eval source context position last effective_axis env fncs):env) fncs @@ -163,10 +161,11 @@ in foldir (\a i r -> (eval body a i undefv3 "" ((var,[a]):(ivar,[XInt i]):env) fncs)++r) [] (eval ns context position last effective_axis env fncs) 1 Ast "sortTuple" (exp:orderBys) -- prepare each FLWOR tuple for sorting - -> [ XElem "" [] 0 (foldl (\r a -> r++[XElem "" [] 0 (text (eval a context position last effective_axis env fncs))]) - [XElem "" [] 0 (eval exp context position last effective_axis env fncs)] orderBys) ] + -> [ XElem "" [] 0 parent_error + (foldl (\r a -> r++[XElem "" [] 0 parent_error (text (eval a context position last effective_axis env fncs))]) + [XElem "" [] 0 parent_error (eval exp context position last effective_axis env fncs)] orderBys) ] Ast "sort" (exp:ordList) -- blocking - -> let ce = map (\(XElem _ _ _ xs) -> map (\(XElem _ _ _ ys) -> ys) xs) + -> let ce = map (\(XElem _ _ _ _ xs) -> map (\(XElem _ _ _ _ ys) -> ys) xs) (eval exp context position last effective_axis env fncs) ordering = foldr (\(Avar ord) r (x:xs) (y:ys) -> case compareXSeqs (ord == "ascending") x y of @@ -245,8 +244,6 @@ | memV path_step pathFunctions -> do vs <- evalM body context position last effective_axis env fncs return (foldr (\x r -> ((findV path_step pathFunctions) tag x)++r) [] vs) - Ast "step" [exp] - -> evalM exp context position last effective_axis env fncs Ast "step" (exp:predicates) -> do vs <- evalM exp context position last effective_axis env fncs applyPredicatesM predicates vs True env fncs @@ -277,7 +274,7 @@ _ -> error ("Undefined function: "++fname) Ast "construction" [Astring tag,Ast "attributes" [],body] -> do b <- evalM body context position last effective_axis env fncs - return [ XElem tag [] 0 b ] + return [ XElem tag [] 0 parent_error b ] Ast "construction" [tag,Ast "attributes" al,body] -> do alc <- mapM (\(Ast "pair" [a,v]) -> do ac <- evalM a context position last effective_axis env fncs @@ -285,7 +282,7 @@ return (qName ac,showXS vc)) al ct <- evalM tag context position last effective_axis env fncs bc <- evalM body context position last effective_axis env fncs - return [ XElem (qName ct) alc 0 bc ] + return [ XElem (qName ct) alc 0 parent_error bc ] Ast "let" [Avar var,source,body] -> do s <- evalM source context position last effective_axis env fncs evalM body context position last effective_axis ((var,s):env) fncs @@ -304,10 +301,11 @@ Ast "sortTuple" (exp:orderBys) -- prepare each FLWOR tuple for sorting -> do vs <- evalM exp context position last effective_axis env fncs os <- mapM (\a -> evalM a context position last effective_axis env fncs) orderBys - return [ XElem "" [] 0 (foldl (\r a -> r++[XElem "" [] 0 (text a)]) [XElem "" [] 0 vs] os) ] + return [ XElem "" [] 0 parent_error (foldl (\r a -> r++[XElem "" [] 0 parent_error (text a)]) + [XElem "" [] 0 parent_error vs] os) ] Ast "sort" (exp:ordList) -- blocking -> do vs <- evalM exp context position last effective_axis env fncs - let ce = map (\(XElem _ _ _ xs) -> map (\(XElem _ _ _ ys) -> ys) xs) vs + let ce = map (\(XElem _ _ _ _ xs) -> map (\(XElem _ _ _ _ ys) -> ys) xs) vs ordering = foldr (\(Avar ord) r (x:xs) (y:ys) -> case compareXSeqs (ord == "ascending") x y of EQ -> r xs ys diff --git a/XML/HXQ/Optimizer.hs b/XML/HXQ/Optimizer.hs --- a/XML/HXQ/Optimizer.hs +++ b/XML/HXQ/Optimizer.hs @@ -4,7 +4,7 @@ - Programmer: Leonidas Fegaras - Email: fegaras@cse.uta.edu - Web: http://lambda.uta.edu/ -- Creation: 05/01/08, last update: 06/10/08 +- Creation: 05/01/08, last update: 06/30/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. @@ -16,10 +16,10 @@ module XML.HXQ.Optimizer(optimize) where +--import Debug.Trace import System.IO.Unsafe import Control.Monad import Char(toLower) -import List(sortBy) import Database.HDBC import HXML(AttList) import XML.HXQ.Parser @@ -104,7 +104,7 @@ = (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) + Ast "step" [Ast "descendant_step" [Astring "*",x]],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)) @@ -222,33 +222,48 @@ andAll (x:xs) = foldl (\a r -> call "and" [a,r]) x xs -substContext :: Ast -> Ast -> Maybe Ast -substContext context e +occursContext :: Ast -> Int +occursContext e = case e of - Ast "call" ((Avar f):xs) - -> do ys <- mapM (substContext context) xs - return (Ast "call" ((Avar f):ys)) + Avar "." -> 1 + Ast "let" _ -> 0 + Ast "for" _ -> 0 + Ast "call" [Avar "SQL",s,f,w] + -> occursContext w Ast "descendant_any" (x:tags) - -> do nx <- substContext context x - return (Ast "descendant_any" (nx:tags)) + -> occursContext x 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 + -> 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 "descendant_any" (x:tags) + -> Ast "descendant_any" ((substContext e x):tags) + Ast step [tag,x] + | elem step paths + -> Ast step [tag,substContext e x] + 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,_,_] | v==w -> 0 Ast "for" [Avar w,Avar i,_,_] | v==w || v==i -> 0 + Ast "call" [Avar "SQL",s,f,w] + -> occurs v w Ast n xs -> sum (map (occurs v) xs) _ -> 0 @@ -259,177 +274,247 @@ Avar w | v==w -> e Ast "let" [Avar w,_,_] | v==w -> b Ast "for" [Avar w,Avar i,_,_] | v==w || v==i -> b + 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 -sqlPredicate :: Ast -> Bool -sqlPredicate e +dependsOnPosition :: Bool -> Ast -> Bool +dependsOnPosition contextp 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 + Avar "." -> contextp + Ast "call" [Avar "position"] -> True + Ast "call" [Avar "last"] -> True + Ast "call" ((Avar "step"):x:_) + -> dependsOnPosition contextp x + Ast _ xs -> any (dependsOnPosition contextp) xs + _ -> False + + +wellFormedPredicate :: Bool -> Ast -> Bool +wellFormedPredicate contextp e + = case e of + Ast "call" ((Avar "step"):x:_) + -> not (dependsOnPosition contextp x) + Ast step xs + | elem step paths || step == "descendant_any" + -> not (any (dependsOnPosition contextp) xs) + 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) sqlFunctions - -> (sqlPredicate x) && (sqlPredicate y) + | any (\(f,_) -> f==cmp) (sqlComparisson++sqlBoolean) + -> not (dependsOnPosition contextp x) + && not (dependsOnPosition contextp y) _ -> False -usesCurrentContext :: Ast -> Bool -usesCurrentContext (Ast _ xs) = any usesCurrentContext xs -usesCurrentContext (Avar ".") = True -usesCurrentContext _ = 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,Ast "call" [Avar "and",p1,pp2]) + (Just(pp1,pp2),Nothing) -> Just(pp1,Ast "call" [Avar "and",p2,pp2]) +splitSqlPredicate tables pred + | sqlPredicate tables pred + = Just(pred,Ast "call" [Avar "true"]) +splitSqlPredicate tables pred = Nothing -- Normalization -normalize :: Ast -> Bool -> (Ast,Bool) -normalize exp changed +normalize :: Ast -> Bool -> Int -> (Ast,Bool,Int) +normalize exp changed count = case exp of Ast "step" [x] - -> normalize x True + -> normalize x True count Ast "step" (x:(Ast "call" [Avar "true"]):xs) - -> normalize (Ast "step" (x:xs)) True + -> norm (Ast "step" (x:xs)) Ast "step" (x:(Ast "call" [Avar "false"]):xs) - -> (empty,True) + -> (empty,True,count) Ast "for" [v,i,Ast "call" [Avar "empty"],b] - -> (empty,True) + -> (empty,True,count) Ast "for" [v,i,s,Ast "call" [Avar "empty"]] - -> (empty,True) + -> (empty,True,count) Ast "descendant_any" ((Astring _):_) - -> (empty,True) + -> (empty,True,count) Ast "descendant_any" ((Aint _):_) - -> (empty,True) + -> (empty,True,count) Ast "descendant_any" ((Afloat _):_) - -> (empty,True) + -> (empty,True,count) Ast "descendant_any" ((Ast "call" [Avar "text",_]):_) - -> (empty,True) + -> (empty,True,count) Ast "descendant_any" ((Ast "call" [Avar "empty"]):_) - -> (empty,True) + -> (empty,True,count) Ast step [_,Astring _] | elem step paths - -> (empty,True) + -> (empty,True,count) Ast step [_,Aint _] | elem step paths - -> (empty,True) + -> (empty,True,count) Ast step [_,Afloat _] | elem step paths - -> (empty,True) + -> (empty,True,count) Ast step [_,Ast "call" [Avar "text",_]] | elem step paths - -> (empty,True) + -> (empty,True,count) Ast step [_,Ast "call" [Avar "empty"]] | elem step paths - -> (empty,True) + -> (empty,True,count) Ast "call" [Avar "and",Ast "call" [Avar "true"],x] - -> normalize x True + -> norm x Ast "call" [Avar "and",x,Ast "call" [Avar "true"]] - -> normalize x True + -> norm x -- (x,()) -> x Ast "call" [Avar "concatenate",x,Ast "call" [Avar "empty"]] - -> normalize x True + -> norm x -- ((),x) -> x Ast "call" [Avar "concatenate",Ast "call" [Avar "empty"],x] - -> normalize x True + -> norm x -- 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 + -> norm (Ast "for" [v2,i2,s2,Ast "for" [v1,i1,b2,b1]]) -- (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 + -> norm (Ast "for" [v,i,s,Ast "descendant_any" (b:tags)]) Ast step [tag,Ast "for" [v,i,s,b]] | elem step paths - -> normalize (Ast "for" [v,i,s,Ast step [tag,b]]) True + -> norm (Ast "for" [v,i,s,Ast step [tag,b]]) -- (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 + -> norm (Ast "call" [Avar "concatenate",Ast "descendant_any" (x:tags),Ast "descendant_any" (y:tags)]) 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 + -> norm (Ast "call" [Avar "concatenate",Ast step [tag,x],Ast step [tag,y]]) -- 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" [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,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 + -> norm (if i == "$" + then subst v e b + else subst v e (subst i (Aint 1) b)) + --Ast "for" [Avar v,Avar i,Ast "predicate" [pred,e],b] + -- -> norm (Ast "for" [Avar v,Avar i,e,Ast "predicate" [pred,b]]) + Ast "for" [Avar v,Avar i,Ast "predicate" [pred,e],b] + | occurs v pred == 0 && occurs i pred == 0 && occursContext pred == 0 + -> norm (Ast "predicate" [pred,Ast "for" [Avar v,Avar i,e,b]]) -- unfold linear let Ast "let" [Avar v,e,b] | occurs v b < 2 - -> normalize (subst v e b) True + -> norm (subst v e b) -- (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 + | wellFormedPredicate True c + -> norm (Ast "predicate" [c,Ast "descendant_any" (e:tags)]) Ast step [tag,Ast "predicate" [c,e]] - | elem step paths && not (usesCurrentContext c) - -> normalize (Ast "predicate" [c,Ast step [tag,e]]) True + | elem step paths && wellFormedPredicate True c + -> norm (Ast "predicate" [c,Ast step [tag,e]]) + -- if p doesn't depend on context: (e[p])/A --> (e/A)[p] + Ast "descendant_any" ((Ast "step" (x:xs@(_:_))):tags) + | all (wellFormedPredicate True) xs + -> norm (Ast "step" ((Ast "descendant_any" (x:tags)):xs)) + Ast step [tag,Ast "step" (x:xs@(_:_))] + | elem step paths && all (wellFormedPredicate True) xs + -> norm (Ast "step" ((Ast step [tag,x]):xs)) -- normalize predicate + Ast "predicate" [pred,x] + | occursContext pred > 0 + -> let v = "x"++show count + in normalize (Ast "for" [Avar v,Avar "$",x,Ast "predicate" [substContext (Avar v) pred,Avar v]]) True (count+1) + Ast "step" [x,pred] + | occursContext pred > 0 + -> let v = "x"++show count + in normalize (Ast "for" [Avar v,Avar "$",x,Ast "predicate" [substContext (Avar v) pred,Avar v]]) True (count+1) + Ast "predicate" [p1,Ast "predicate" [p2,e]] + -> norm (Ast "predicate" [Ast "call" [Avar "and",p1,p2],e]) + Ast "predicate" [Ast "call"[Avar "false"],x] + -> (empty,True,count) Ast "predicate" [Ast "call"[Avar "true"],x] - -> (empty,True) + -> (x,True,count) Ast "predicate" [x,Ast "call"[Avar "empty"]] - -> (empty,True) + -> (empty,True,count) Ast "step" ((Ast "call" [Avar "empty"]):xs) - -> (empty,True) + -> (empty,True,count) + -- promote well-formed predicates; but note: (x,y)[1] <> (x[1],y[1]) Ast "step" ((Ast "call" [Avar "concatenate",x,y]):xs) - -> normalize (Ast "call" [Avar "concatenate",Ast "step" (x:xs),Ast "step" (y:xs)]) True + | all (wellFormedPredicate False) xs + -> norm (Ast "call" [Avar "concatenate",Ast "step" (x:xs),Ast "step" (y:xs)]) + Ast "predicate" [pred,Ast "for" [v,i,s,b]] + | wellFormedPredicate False pred + -> norm (Ast "for" [v,i,s,Ast "predicate" [pred,b]]) Ast "step" ((Ast "for" [v,i,s,b]):xs) - -> normalize (Ast "for" [v,i,s,Ast "step" (b:xs)]) True + | all (wellFormedPredicate False) xs + -> norm (Ast "for" [v,i,s,Ast "predicate" [andAll xs,b]]) 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) + -> if sum (map occursContext xs) > 0 + then norm (Ast "predicate" [andAll (map (substContext e) xs),e]) + else let (r,b,c) = foldr (\a (r,b,c) -> let (x,s,i) = normalize a b c in (x:r,s,i)) + ([],changed,count) (e:xs) + in (Ast "step" r,b,c) Ast "call" [Avar "=",x,y] | x == empty || y == empty - -> (Ast "call"[Avar "true"],True) + -> (Ast "call"[Avar "true"],True,count) -- (.........)/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 + Just [] -> (empty,True,count) + Just s -> norm (concatenateAll s) Ast "child_step" [Astring tag,Ast "construction" [_,_,Ast "append" x]] - -> normalize (Ast "current_step" [Astring tag,concatenateAll x]) True + -> norm (Ast "current_step" [Astring tag,concatenateAll x]) Ast "current_step" [Astring tag1,e@(Ast "construction" [Astring tag2,_,Ast "append" x])] -> if tag1 == tag2 || tag1 == "*" - then normalize e True - else (empty,True) + then norm e + else (empty,True,count) -- (x)//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 + -> norm (Ast "call" [Avar "concatenate",z,Ast "descendant_any" ((concatenateAll x):tags)]) 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 + -> norm (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]) -- (x)/@A --> s Ast "attribute_step" [Astring tag,Ast "construction" [ctag,Ast "attributes" as,x]] - -> (findAttr tag as,True) + -> (findAttr tag as,True,count) -- (x)//@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 + -> norm (Ast "call" [Avar "concatenate",findAttr tag as, + Ast "attribute_descendant_step" [Astring tag,concatenateAll x]]) -- 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], + | occurs v1 b == 0 + -> norm (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]) + Ast "for" [Avar v,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s),Ast "call" ((Avar "from"):tables),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 + | 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 "from"):tables),Ast "call" [Avar "and",pred1,pred3]], + Ast "predicate" [pred4,x]]) + 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], + 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 "from"):f1),Ast "call" [Avar "and",pred1,pred3]], + Ast "for" [Avar v2,Avar "$",Ast "call" [Avar "SQL",Ast "call" ((Avar "select"):s2),Ast "call" ((Avar "from"):f2),pred2], + Ast "predicate" [pred4,b]]]) -- 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) + -> 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 = normalize e True count + --tnorm e = trace ("*** "++show exp++"\n--> "++ppAst e) (normalize e True count) foldSQL :: Ast -> Ast @@ -442,11 +527,12 @@ _ -> e -optimizeLoop :: Ast -> Ast -optimizeLoop e = let (ne,b) = normalize e False - in if b - then optimizeLoop ne - else ne +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 (optimizeLoop (simplify e)) +optimize e = foldSQL (fst (optimizeLoop (simplify e) 0)) diff --git a/XML/HXQ/XTree.hs b/XML/HXQ/XTree.hs --- a/XML/HXQ/XTree.hs +++ b/XML/HXQ/XTree.hs @@ -34,7 +34,7 @@ -- | Rose tree representation of XML data. -- The Int in XElem is the preorder numbering used for the document order of nodes. -data XTree = XElem !Tag !AttList !Int [XTree] -- ^ an XML tree node (element) +data XTree = XElem !Tag !AttList !Int XTree [XTree] -- ^ an XML tree node (element) | XText !String -- ^ an XML tree leaf (PCDATA) | XInt !Int -- ^ an XML tree leaf (int) | XFloat !Float -- ^ an XML tree leaf (float) @@ -57,8 +57,8 @@ showXT :: XTree -> Bool -> String showXT e pad = case e of - XElem tag al _ [] -> "<"++tag++showAL al++"/>" - XElem tag al _ xs -> "<"++tag++showAL al++">"++showXS xs++"" + XElem tag al _ _ [] -> "<"++tag++showAL al++"/>" + XElem tag al _ _ xs -> "<"++tag++showAL al++">"++showXS xs++"" XText text -> p++text XInt n -> p++show n XFloat n -> p++show n @@ -91,23 +91,57 @@ type Stream = [XMLEvent] +noParentError = error "parent references are not supported yet" -- lazily materialize the SAX stream into a DOM tree +materializeWithoutParent :: Stream -> XTree +materializeWithoutParent stream + = XElem "document" [] 1 noParentError + [head (filter (\x -> case x of XElem _ _ _ _ _ -> True; _ -> False) + ((\(x,_,_)->x) (ml stream 2)))] + where m ((TextEvent t):xs) i = (XText t,xs,i) + m ((EmptyEvent n atts):xs) i = (XElem n atts i noParentError [],xs,i+1) + m ((StartEvent n atts):xs) i + = let (el,xs',i') = ml xs (i+1) + in (XElem n atts i noParentError el,xs',i') + m ((PIEvent n s):xs) i = (XPI n s,xs,i) + m ((CommentEvent s):xs) i = (XComment s,xs,i) + m ((GERefEvent n):xs) i = (XGERef n,xs,i) + m ((ErrorEvent s):xs) i = (XError s,xs,i) + m (_:xs) i = (XError "unrecognized XML event",xs,i) + m [] i = (XError "unbalanced tags",[],i) + ml [] i = ([],[],i) + ml ((EndEvent n):xs) i = ([],xs,i) + ml xs i = let (e,xs',i') = m xs i + (el,xs'',i'') = ml xs' i' + in (e:el,xs'',i'') + + +-- lazily materialize the SAX stream into a DOM tree that contains parent references +-- Not used because it has space leaks for large documents +materializeWithParent :: Stream -> XTree +materializeWithParent stream = root + where root = XElem "document" [] 1 (error "Trying to access the root parent") + [head (filter (\x -> case x of XElem _ _ _ _ _ -> True; _ -> False) + ((\(x,_,_)->x) (ml stream 2 root)))] + m ((TextEvent t):xs) i _ = (XText t,xs,i) + m ((EmptyEvent n atts):xs) i p = (XElem n atts i p [],xs,i+1) + m ((StartEvent n atts):xs) i p + = let (el,xs',i') = ml xs (i+1) node + node = XElem n atts i p el + in (node,xs',i') + m ((PIEvent n s):xs) i _ = (XPI n s,xs,i) + m ((CommentEvent s):xs) i _ = (XComment s,xs,i) + m ((GERefEvent n):xs) i _ = (XGERef n,xs,i) + m ((ErrorEvent s):xs) i _ = (XError s,xs,i) + m (_:xs) i _ = (XError "unrecognized XML event",xs,i) + m [] i _ = (XError "unbalanced tags",[],i) + ml [] i _ = ([],[],i) + ml ((EndEvent n):xs) i _ = ([],xs,i) + ml xs i p = let (e,xs',i') = m xs i p + (el,xs'',i'') = ml xs' i' p + in (e:el,xs'',i'') + + materialize :: Stream -> XTree -materialize stream = XElem "document" [] 1 [head (filter (\x -> case x of XElem _ _ _ _ -> True; _ -> False) - ((\(x,_,_)->x) (ml stream 2)))] - where m ((TextEvent t):xs) i = (XText t,xs,i) - m ((EmptyEvent n atts):xs) i = (XElem n atts i [],xs,i+1) - m ((StartEvent n atts):xs) i = let (el,xs',i') = ml xs (i+1) - in (XElem n atts i el,xs',i') - m ((PIEvent n s):xs) i = (XPI n s,xs,i) - m ((CommentEvent s):xs) i = (XComment s,xs,i) - m ((GERefEvent n):xs) i = (XGERef n,xs,i) - m ((ErrorEvent s):xs) i = (XError s,xs,i) - m (_:xs) i = (XError "unrecognized XML event",xs,i) - m [] i = (XError "unbalanced tags",[],i) - ml [] i = ([],[],i) - ml ((EndEvent n):xs) i = ([],xs,i) - ml xs i = let (e,xs',i') = m xs i - (el,xs'',i'') = ml xs' i' - in (e:el,xs'',i'') +materialize = materializeWithoutParent diff --git a/data/q1.xq b/data/q1.xq --- a/data/q1.xq +++ b/data/q1.xq @@ -4,9 +4,8 @@ declare function f ( $name, $gpa ) { { $name/firstname/text(), - $name/lastname/text(), - ':',$gpa - } + $name/lastname/text() + }: {$gpa} }; { diff --git a/index.html b/index.html --- a/index.html +++ b/index.html @@ -45,7 +45,7 @@ HDBC-sqlite3 driver to connect to SQLite relational databases.

-Finally, download HXQ and untar it. +Finally, download HXQ and untar it. You can use either make or cabal to build it. To build it with cabal, you do: 

 runhaskell Setup.lhs configure --prefix=$HOME
@@ -80,7 +80,7 @@
 
  •  $(xq query) :: IO XSeq
 
 where query is a string value (a Haskell expression that evaluates
-to a string at compile-time), They both translate the query into Haskell
+to a string at compile-time). They both translate the query into Haskell
 code, which is compiled and optimized into machine code directly.
 The code that xe generates has type XSeq (a sequence of XML trees of type [XTree])
 while the code that xq generates has type (IO XSeq). If the query reads
@@ -138,7 +138,8 @@
 
    
 
    Database Connectivity
    
 
    
-HXQ provides an interface to HDBC to query relational data inside an XQuery.
+HXQ provides an interface to HDBC
+to query relational data inside an XQuery.
 For the HXQ compiler, the main function that allows database connectivity is:
 
     $(xqdb query) :: (IConnection conn) => conn -> IO XSeq
@@ -152,7 +153,7 @@
 
     xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq
 
    
-The xquery executable can also run xqueries that use a database by specifying the database name using the -db option.
+The xquery executable can also run XQueries that use a database by specifying the database name using the -db option.
 
    
 Currently, HXQ works with SQLite only, but is very easy to make it work
 with any relational database that supports ODBC: simply install 
@@ -219,4 +220,4 @@
 
    
 
    
 
    
-
    Last modified: 06/12/08 by Leonidas Fegaras
    
+
    Last modified: 06/27/08 by Leonidas Fegaras