module Text.XML.HXQ.Interpreter
( xquery, xqueryDB, xfileDB, evalInput, xqueryE ) where
import Text.XML.HXQ.Parser
import Text.XML.HXQ.XTree
import Text.XML.HXQ.OptionalDB
import Control.Monad
import List(sortBy)
import XMLParse(parseDocument)
import Readline
import Text.XML.HXQ.Optimizer
import Text.XML.HXQ.Functions
import Text.XML.HXQ.Compiler
type Environment = [(String,XSeq)]
type Functions = [(String,[String],Ast)]
undefv1 = error "Undefined XQuery context (.)"
undefv2 = error "Undefined position()"
undefv3 = error "Undefined last()"
applyPredicates :: [Ast] -> XSeq -> Bool -> Environment -> Functions -> XSeq
applyPredicates [] xs _ _ _ = xs
applyPredicates ((Aint n):preds) xs _ env fncs
= applyPredicates preds [xs !! (n1)] True env fncs
applyPredicates (pred:preds) xs True env fncs
| maxPosition pathPosition pred > 0
= applyPredicates (pred:preds) (take (maxPosition pathPosition pred) xs) False env fncs
applyPredicates (pred:preds) xs _ env fncs
| containsLast pred
= let last = length xs
in applyPredicates preds
(foldir (\x i r -> case eval pred x i last "" env fncs of
[XInt k] -> if k == i then x:r else r
b -> if conditionTest b then x:r else r) [] xs 1) True env fncs
applyPredicates (pred:preds) xs _ env fncs
= applyPredicates preds
(foldir (\x i r -> case eval pred x i undefv3 "" env fncs of
[XInt k] -> if k == i then x:r else r
b -> if conditionTest b then x:r else r) [] xs 1) True env fncs
eval :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> XSeq
eval e context position last effective_axis env fncs
= case e of
Avar "." -> [ context ]
Avar v -> findV v env
Aint n -> [ XInt n ]
Afloat n -> [ XFloat n ]
Astring s -> [ XText s ]
Ast "context" [v,Astring dp,body]
-> foldr (\x r -> (eval body x position last dp env fncs)++r)
[] (eval v context position last effective_axis env fncs)
Ast "call" [Avar "position"] -> [XInt position]
Ast "call" [Avar "last"] -> [XInt last]
Ast "step" (Avar "child":tag:Avar ".":preds)
| effective_axis /= ""
-> eval (Ast "step" (Avar effective_axis:tag:Avar ".":preds)) context position last "" env fncs
Ast "step" (Avar "descendant_any":Ast "tags" tags:e:preds)
-> let ts = map (\(Avar tag) -> tag) tags
v = eval e context position last effective_axis env fncs
in if v==[XNull]
then v
else foldr (\x r -> (applyPredicates preds (descendant_any_with_tagged_children ts x) True env fncs)++r) [] v
Ast "step" (Avar step:Astring tag:e:preds)
-> let step_fnc = findV step pathFunctions
v = eval e context position last effective_axis env fncs
in if v==[XNull]
then v
else foldr (\x r -> (applyPredicates preds (step_fnc tag x) True env fncs)++r) [] v
Ast "filter" (e:preds)
-> applyPredicates preds (eval e context position last effective_axis env fncs) True env fncs
Ast "predicate" [condition,body]
-> if conditionTest (eval condition undefv1 undefv2 undefv3 "" env fncs)
then eval body context position last effective_axis env fncs
else []
Ast "append" args
-> appendText (map (\x -> eval x context position last effective_axis env fncs) args)
Ast "if" [c,t,e]
-> if conditionTest (eval c context position last effective_axis env fncs)
then eval t context position last effective_axis env fncs
else eval e context position last effective_axis env fncs
Ast f _
| elem f ["insert","delete","replace"]
-> error "Updates must be over XML data stored in databases"
Ast "call" ((Avar fname):args)
-> let vs = map (\x -> eval x context position last effective_axis env fncs) args
in case filter (\(n,_,_) -> n == fname || ("fn:"++n) == fname) systemFunctions of
[(_,len,f)] -> if (length args) == len
then f vs
else error ("Wrong number of arguments in system call: "++fname)
_ -> error "External function calls must be within the IO monad"
Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body]
-> let [XText vid] = eval id context position last effective_axis env fncs
vparent = eval parent context position last effective_axis env fncs
in [ XElem tag [] (read vid) (if null vparent then parent_error else head vparent)
(eval body context position last effective_axis env fncs) ]
Ast "construction" [tag,id,parent,Ast "attributes" al,body]
-> let alc = concatMap (\(Ast "pair" [a,v])
-> let ac = eval a context position last effective_axis env fncs
vc = eval v context position last effective_axis env fncs
in if vc==[XNull] then [] else [(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
[XText vid] = eval id context position last effective_axis env fncs
vparent = eval parent context position last effective_axis env fncs
in [ XElem (qName ct) alc (read vid) (if null vparent then parent_error else head vparent) 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
Ast "for" [Avar var,Avar "$",source,body]
-> foldr (\a r -> (eval body a undefv2 undefv3 "" ((var,[a]):env) fncs)++r)
[] (eval source context position last effective_axis env fncs)
Ast "for" [Avar var,Avar ivar,source,body]
-> let p = maxPosition (Avar ivar) body
ns = if p > 0
then Ast "step" [source,Ast "call" [Avar "<=",pathPosition,Aint p]]
else source
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)
-> let ee = eval exp context position last effective_axis env fncs
in [ 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 ee] orderBys) ]
Ast "sort" (exp:ordList)
-> 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
EQ -> r xs ys
o -> o)
(\xs ys -> EQ) ordList
in concatMap head (sortBy (\(_:xs) (_:ys) -> ordering xs ys) ce)
_ -> error ("Illegal XQuery: "++(show e))
type Statements = [(String,Statement)]
applyPredicatesM :: [Ast] -> XSeq -> Bool -> Environment -> Functions -> Connection -> Statements -> IO XSeq
applyPredicatesM [] xs _ _ _ _ _ = return $! xs
applyPredicatesM ((Aint n):preds) xs _ env fncs db stmts
= applyPredicatesM preds [xs !! (n1)] True env fncs db stmts
applyPredicatesM (pred:preds) xs True env fncs db stmts
| maxPosition pathPosition pred > 0
= applyPredicatesM (pred:preds) (take (maxPosition pathPosition pred) xs) False env fncs db stmts
applyPredicatesM (pred:preds) xs _ env fncs db stmts
| containsLast pred
= do let last = length xs
vs <- foldir (\x i r -> do vs <- evalM pred x i last "" env fncs db stmts
s <- r
return $! (if case vs of
[XInt k] -> k == i
b -> conditionTest b
then x:s else s))
(return []) xs 1
applyPredicatesM preds vs True env fncs db stmts
applyPredicatesM (pred:preds) xs _ env fncs db stmts
= do vs <- foldir (\x i r -> do vs <- evalM pred x i undefv3 "" env fncs db stmts
s <- r
return $! (if case vs of
[XInt k] -> k == i
b -> conditionTest b
then x:s else s))
(return []) xs 1
applyPredicatesM preds vs True env fncs db stmts
evalM :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> Connection -> Statements -> IO XSeq
evalM e context position last effective_axis env fncs db stmts
= case e of
Avar "." -> return $! [ context ]
Avar v -> return $! (findV v env)
Aint n -> return $! [ XInt n ]
Afloat n -> return $! [ XFloat n ]
Astring s -> return $! [ XText s ]
Ast "nonIO" [u] -> return $! (eval u context position last effective_axis env fncs)
Ast "context" [v,Astring dp,body]
-> do vs <- evalM v context position last effective_axis env fncs db stmts
foldr (\x r -> (liftM2 (++)) (evalM body x position last dp env fncs db stmts) r)
(return []) vs
Ast "call" [Avar "position"] -> return $! [XInt position]
Ast "call" [Avar "last"] -> return $! [XInt last]
Ast "call" [Avar f,Astring file]
| elem f ["doc","fn:doc"]
-> do doc <- readFile file
return [materialize False (parseDocument doc)]
Ast "step" (Avar "child":tag:Avar ".":preds)
| effective_axis /= ""
-> evalM (Ast "step" (Avar effective_axis:tag:Avar ".":preds)) context position last "" env fncs db stmts
Ast "step" (Avar "descendant_any":Ast "tags" tags:e:preds)
-> do vs <- evalM e context position last effective_axis env fncs db stmts
let ts = map (\(Avar tag) -> tag) tags
if vs==[XNull]
then return vs
else foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (descendant_any_with_tagged_children ts x)
True env fncs db stmts) r)
(return []) vs
Ast "step" (Avar step:Astring tag:e:preds)
-> let step_fnc = findV step pathFunctions
in do vs <- evalM e context position last effective_axis env fncs db stmts
if vs==[XNull]
then return vs
else foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (step_fnc tag x)
True env fncs db stmts) r)
(return []) vs
Ast "filter" (e:preds)
-> do vs <- evalM e context position last effective_axis env fncs db stmts
applyPredicatesM preds vs True env fncs db stmts
Ast "predicate" [condition,body]
-> do eb <- evalM condition undefv1 undefv2 undefv3 "" env fncs db stmts
if conditionTest eb
then evalM body context position last effective_axis env fncs db stmts
else return []
Ast "executeSQL" [Avar var,args]
-> do as <- evalM args context position last effective_axis env fncs db stmts
executeSQL (findV var stmts) as
Ast "append" args
-> (liftM appendText) (mapM (\x -> evalM x context position last effective_axis env fncs db stmts) args)
Ast "if" [c,t,e]
-> do ce <- evalM c context position last effective_axis env fncs db stmts
evalM (if conditionTest ce then t else e) context position last effective_axis env fncs db stmts
Ast "insert" [e1,e2]
-> do v1 <- evalM e1 context position last effective_axis env fncs db stmts
v2 <- evalM e2 context position last effective_axis env fncs db stmts
insertDB db v1 v2
Ast "delete" [e]
-> do v <- evalM e context position last effective_axis env fncs db stmts
deleteDB db v
Ast "replace" [e1,e2]
-> do v1 <- evalM e1 context position last effective_axis env fncs db stmts
v2 <- evalM e2 context position last effective_axis env fncs db stmts
replaceDB db v1 v2
Ast "call" ((Avar fname):args)
-> case filter (\(n,_,_) -> n == fname || ("fn:"++n) == fname) systemFunctions of
[(_,len,f)] -> if (length args) == len
then do vs <- mapM (\x -> evalM x context position last effective_axis env fncs db stmts) args
return $ f vs
else error ("Wrong number of arguments in system call: "++fname)
_ -> case filter (\(n,_,_) -> n == fname) fncs of
(_,params,body):_ -> if (length params) == (length args)
then do vs <- mapM (\a -> evalM a context position last effective_axis env fncs db stmts) args
evalM body context undefv2 undefv3 ""
((zipWith (\p a -> (p,a)) params vs)++env) fncs db stmts
else error ("Wrong number of arguments in function call: "++fname)
_ -> error ("Undefined function: "++fname)
Ast "construction" [Astring tag,id,parent,Ast "attributes" [],body]
-> do b <- evalM body context position last effective_axis env fncs db stmts
[XText vid] <- evalM id context position last effective_axis env fncs db stmts
vparent <- evalM parent context position last effective_axis env fncs db stmts
return $! [ XElem tag [] (read vid) (if null vparent then parent_error else head vparent) b ]
Ast "construction" [tag,id,parent,Ast "attributes" al,body]
-> do alc <- foldM (\r (Ast "pair" [a,v])
-> do ac <- evalM a context position last effective_axis env fncs db stmts
vc <- evalM v context position last effective_axis env fncs db stmts
if vc==[XNull] then return r else return $! (qName ac,showXS vc):r) [] al
ct <- evalM tag context position last effective_axis env fncs db stmts
bc <- evalM body context position last effective_axis env fncs db stmts
[XText vid] <- evalM id context position last effective_axis env fncs db stmts
vparent <- evalM parent context position last effective_axis env fncs db stmts
return $! [ XElem (qName ct) alc (read vid) (if null vparent then parent_error else head vparent) bc ]
Ast "let" [Avar var,source,body]
-> do s <- evalM source context position last effective_axis env fncs db stmts
evalM body context position last effective_axis ((var,s):env) fncs db stmts
Ast "for" [Avar var,Avar "$",source,body]
-> do vs <- evalM source context position last effective_axis env fncs db stmts
foldr (\a r -> (liftM2 (++)) (evalM body a undefv2 undefv3 "" ((var,[a]):env) fncs db stmts) r)
(return []) vs
Ast "for" [Avar var,Avar ivar,source,body]
-> do let p = maxPosition (Avar ivar) body
ns = if p > 0
then Ast "step" [source,Ast "call" [Avar "<=",pathPosition,Aint p]]
else source
vs <- evalM ns context position last effective_axis env fncs db stmts
foldir (\a i r -> (liftM2 (++)) (evalM body a i undefv3 "" ((var,[a]):(ivar,[XInt i]):env) fncs db stmts) r)
(return []) vs 1
Ast "sortTuple" (exp:orderBys)
-> do vs <- evalM exp context position last effective_axis env fncs db stmts
os <- mapM (\a -> evalM a context position last effective_axis env fncs db stmts) orderBys
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)
-> do vs <- evalM exp context position last effective_axis env fncs db stmts
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
o -> o)
(\xs ys -> EQ) ordList
return $! (concatMap head (sortBy (\(_:xs) (_:ys) -> ordering xs ys) ce))
_ -> error ("Illegal XQuery: "++(show e))
evalInput :: (String -> Environment -> Functions -> IO(Environment,Functions)) -> Environment -> Functions -> IO ()
evalInput eval vs fs
= do let oneline prompt = do line <- readline prompt
case line of
Nothing -> return "quit"
Just t -> if t == ""
then oneline prompt
else return $! t
readlines x = do line <- oneline ": "
if last line == '}'
then return $! (x++" "++(init line))
else if line == "quit"
then return $! line
else readlines (x++" "++line)
line <- oneline "> "
stmt <- if head line == '{'
then if last line == '}'
then return $! (init (tail line))
else readlines (tail line)
else return $! line
if stmt == "quit"
then putStrLn "Bye!"
else do addHistory stmt
(nvs,nfs) <- eval (map (\c -> if c=='\"' then '\'' else c) stmt) vs fs
evalInput eval nvs nfs
evalQueryM :: [Ast] -> Environment -> Functions -> Connection -> Bool -> IO (XSeq,Environment,Functions)
evalQueryM [] variables functions db verbose
= return $! ([],variables,functions)
evalQueryM (query:xs) variables functions db verbose
= case query of
Ast "function" ((Avar f):body:args)
-> do let opt = optimize body
if verbose
then do putStrLn "Abstract Syntax Tree (AST):"
putStrLn (ppAst body)
putStrLn "Optimized AST:"
putStrLn (ppAst opt)
else return ()
evalQueryM xs variables ((f,map (\(Avar v) -> v) args,opt):functions) db verbose
Ast "variable" [Avar v,u]
-> do uv <- evalM (optimize u) undefv1 undefv2 undefv3 "" variables functions db []
evalQueryM xs ((v,uv):variables) functions db verbose
_ -> do let opt = optimize query
(ast,ns) = liftIOSources opt
if verbose
then do putStrLn "Abstract Syntax Tree (AST):"
putStrLn (ppAst query)
putStrLn "Optimized AST:"
putStrLn (ppAst opt)
putStrLn "Result:"
else return ()
env <- foldr (\(n,b,s) r -> case s of
Avar m
-> do env <- r
return $! ((n,findV m env):env)
Astring file
-> do doc <- readFile file
env <- r
return $! ((n,[materialize b (parseDocument doc)]):env)
_ -> r)
(return []) ns
stmts <- foldr (\(n,_,s) r -> case s of
Ast "prepareSQL" [Astring sql]
-> do stmts <- r
t <- prepareSQL db sql
return $! ((n,t):stmts)
_ -> r)
(return []) ns
result <- evalM ast undefv1 undefv2 undefv3 "" (env++variables) functions db stmts
(rest,renv,rfuns) <- evalQueryM xs variables functions db verbose
return $! (result++rest,renv,rfuns)
xqueryE :: String -> Environment -> Functions -> Connection -> Bool -> IO (XSeq,Environment,Functions)
xqueryE query variables functions db verbose
= evalQueryM (parse (scan query)) variables functions db verbose
xquery :: String -> IO XSeq
xquery query = do (u,_,_) <- xqueryE query [] [] (error "No database connectivity") False
return $! u
xqueryDB :: String -> Connection -> IO XSeq
xqueryDB query db = do (u,_,_) <- xqueryE query [] [] db False
return $! u
xfileDB :: String -> Connection -> IO XSeq
xfileDB file db = do query <- readFile file
xqueryDB query db