HXQ 0.8.3 → 0.8.4
raw patch · 11 files changed
+422/−213 lines, 11 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- XML.HXQ.XQuery: XElem :: !Tag -> !AttList -> !Int -> [XTree] -> XTree
+ XML.HXQ.XQuery: XElem :: !Tag -> !AttList -> !Int -> XTree -> [XTree] -> XTree
Files
- HXQ-unstable.hs +1/−1
- HXQ.cabal +2/−1
- Main.hs +4/−3
- TestDB2.hs +23/−0
- XML/HXQ/Compiler.hs +45/−38
- XML/HXQ/DB.hs +79/−20
- XML/HXQ/Interpreter.hs +12/−14
- XML/HXQ/Optimizer.hs +194/−108
- XML/HXQ/XTree.hs +54/−20
- data/q1.xq +2/−3
- index.html +6/−5
HXQ-unstable.hs view
@@ -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 = "./"
HXQ.cabal view
@@ -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
Main.hs view
@@ -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"
+ TestDB2.hs view
@@ -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
XML/HXQ/Compiler.hs view
@@ -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)) |]
XML/HXQ/DB.hs view
@@ -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 = "<root>{" ++ publishS table "error" ++ "}</root>" -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)
XML/HXQ/Interpreter.hs view
@@ -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
XML/HXQ/Optimizer.hs view
@@ -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 <a>...</a> return b --> b[$v/(<a>...</a>)] 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) -- (<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+ 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) -- (<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+ -> 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]) -- (<tag A=s>x</tag>)/@A --> s Ast "attribute_step" [Astring tag,Ast "construction" [ctag,Ast "attributes" as,x]]- -> (findAttr tag as,True)+ -> (findAttr tag as,True,count) -- (<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+ -> 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))
XML/HXQ/XTree.hs view
@@ -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++"</"++tag++">"+ XElem tag al _ _ [] -> "<"++tag++showAL al++"/>"+ XElem tag al _ _ xs -> "<"++tag++showAL al++">"++showXS xs++"</"++tag++">" 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
data/q1.xq view
@@ -4,9 +4,8 @@ declare function f ( $name, $gpa ) { <student>{ $name/firstname/text(),- $name/lastname/text(),- ':',$gpa- }</student>+ $name/lastname/text()+ }: {$gpa}</student> }; <students>{
index.html view
@@ -45,7 +45,7 @@ <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC-sqlite3">HDBC-sqlite3</a> driver to connect to SQLite relational databases. <p>-Finally, download <a href="/HXQ-0.8.3.tar.gz">HXQ</a> and untar it.+Finally, download <a href="/HXQ-0.8.4.tar.gz">HXQ</a> and untar it. You can use either make or cabal to build it. To build it with cabal, you do: <pre> runhaskell Setup.lhs configure --prefix=$HOME@@ -80,7 +80,7 @@ <li> <tt>$(xq query) :: IO XSeq</tt> </ul> where <tt>query</tt> is a string value (a Haskell expression that evaluates-to a string <b>at compile-time</b>), They both translate the query into Haskell+to a string <b>at compile-time</b>). They both translate the query into Haskell code, which is compiled and optimized into machine code directly. The code that xe generates has type <tt>XSeq</tt> (a sequence of XML trees of type <tt>[XTree]</tt>) while the code that xq generates has type <tt>(IO XSeq)</tt>. If the query reads@@ -138,7 +138,8 @@ <p> <h2>Database Connectivity</h2> <p>-HXQ provides an interface to HDBC to query relational data inside an XQuery.+HXQ provides an interface to <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HDBC">HDBC</a>+to query relational data inside an XQuery. For the HXQ compiler, the main function that allows database connectivity is: <pre> $(xqdb query) :: (IConnection conn) => conn -> IO XSeq@@ -152,7 +153,7 @@ <pre> xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq </pre>-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. <p> Currently, HXQ works with <a href="http://sqlite.org/">SQLite</a> only, but is very easy to make it work with any relational database that supports ODBC: simply install @@ -219,4 +220,4 @@ <p> <hr> <p>-<address>Last modified: 06/12/08 by <a href="http://lambda.uta.edu/">Leonidas Fegaras</a></address>+<address>Last modified: 06/27/08 by <a href="http://lambda.uta.edu/">Leonidas Fegaras</a></address>