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 Data.List(foldl')
import Char(isSpace)
import XMLParse(parseDocument)
import Text.XML.HXQ.Optimizer
import Text.XML.HXQ.Functions
import Text.XML.HXQ.Compiler
import Text.XML.HXQ.Types
import Text.XML.HXQ.TypeInference
import System.Console.Haskeline
import System.Console.Haskeline.History
import Control.Monad.Trans(liftIO)
import Control.Monad.State.Class
type Environment = [(String,XSeq)]
type Functions = [(QName,[String],Ast,([Type],Type))]
type Views = [(String,[String],Ast)]
undefv1 = error "Undefined XQuery context (.)"
undefv2 = error "Undefined position()"
undefv3 = error "Undefined last()"
applyPredicates :: [Ast] -> XSeq -> Environment -> Functions -> NS -> XSeq
applyPredicates preds xs env fncs ns
= foldl' (\s p -> applyPred s p True) xs preds
where applyPred [] _ _ = []
applyPred xs (Aint n) _
= index xs (n1)
applyPred xs (Ast "call" [Avar "last"]) _
= [ last xs ]
applyPred xs pred True
| pos > 0
= applyPred (take pos xs) pred False
where pos = maxPosition pathPosition pred
applyPred xs pred _
| containsLast pred
= let last = length xs
in foldir (\x i r -> case eval pred x i last "" env fncs ns of
[XInt k] -> if k == i then x:r else r
b -> if conditionTest b then x:r else r) [] xs 1
applyPred xs pred _
= foldir (\x i r -> case eval pred x i undefv3 "" env fncs ns of
[XInt k] -> if k == i then x:r else r
b -> if conditionTest b then x:r else r) [] xs 1
eval :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> NS -> XSeq
eval e context position last effective_axis env fncs ns
= case e of
Avar "." -> [ context ]
Avar v -> findV v env
Ast "global" [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 ns)++r)
[] (eval v context position last effective_axis env fncs ns)
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 ns
Ast "step" (Avar "descendant_any":Ast "tags" tags:e:preds)
-> let ts = map (\(Avar n) -> tag n ns) tags
in case eval e context position last effective_axis env fncs ns of
v@[XNull] -> v
v -> foldr (\x r -> (applyPredicates preds (descendant_any_with_tagged_children ts x) env fncs ns)++r) [] v
Ast "step" (Avar step:Astring n:e:preds)
-> let step_fnc = findV step pathFunctions
tagname = tag n ns
in case eval e context position last effective_axis env fncs ns of
v@[XNull] -> v
v -> foldr (\x r -> (applyPredicates preds (step_fnc tagname x) env fncs ns)++r) [] v
Ast "filter" (e:preds)
-> applyPredicates preds (eval e context position last effective_axis env fncs ns) env fncs ns
Ast "predicate" [condition,body]
-> if conditionTest (eval condition undefv1 undefv2 undefv3 "" env fncs ns)
then eval body context position last effective_axis env fncs ns
else []
Ast "append" args
-> appendText (map (\x -> eval x context position last effective_axis env fncs ns) args)
Ast "if" [c,t,e]
-> if conditionTest (eval c context position last effective_axis env fncs ns)
then eval t context position last effective_axis env fncs ns
else eval e context position last effective_axis env fncs ns
Ast "validate" [e]
-> let vs = eval e context position last effective_axis env fncs ns
in case validateXSeq vs ns of
Success xs -> vs
Failure ts -> error ("Failed to validate the XML element: "++show ts)
Ast f _
| elem f ["insert","delete","replace"]
-> error "Updates must be over XML data stored in databases"
Ast "call" (v@(Avar fname):args)
-> let vs = map (\x -> eval x context position last effective_axis env fncs ns) args
fn = functionTag fname ns
t = tag fname ns
in if uri t == xsNamespace && isBuildInType (localName t) && length vs == 1
then castAs (head vs) (TBase t)
else case filter (\(n,_,_,_,_) -> n == localName fn) systemFunctions of
[] -> error "External function calls must be within the IO monad"
fs -> case filter (\(_,len,_,_,_) -> len < 0 || length args == len) fs of
[] -> error ("wrong number of arguments in function call: " ++ fname)
(_,_,_,f,_):_ -> f vs
Ast "construction" [tag,id,parent,Ast "attributes" al,body]
-> let ct = eval tag context position last effective_axis env fncs ns
bc = eval body context position last effective_axis env fncs ns
(as,bs) = span (\x -> case x of XAttr _ _ -> True; _ -> False) bc
alc = concatMap (\(Ast "pair" [a,v])
-> let ac = eval a context position last effective_axis env fncs ns
vc = eval v context position last effective_axis env fncs ns
in makeAttribute ac vc ns) al
++ [ (n,v) | XAttr n v <- as ]
vid = case eval id context position last effective_axis env fncs ns of
[XText vid] -> (read vid)::Int
_ -> 0
vparent = eval parent context position last effective_axis env fncs ns
in [ XElem (qName ct ns) alc vid (if null vparent then parent_error else head vparent) bs ]
Ast "attribute_construction" [name,value]
-> let nms = eval name context position last effective_axis env fncs ns
vs = eval value context position last effective_axis env fncs ns
in case nms of
[XText s] -> [ XAttr (attributeTag s ns) (showXS vs) ]
_ -> error ("Illegal attribute: "++show e)
Ast "let" [Avar var,source,body]
-> let es = eval source context position last effective_axis env fncs ns
in eval body context position last effective_axis ((var,es):env) fncs ns
Ast "for" [Avar var,Avar "$",source,body]
-> foldr (\a r -> (eval body a undefv2 undefv3 "" ((var,[a]):env) fncs ns)++r)
[] (eval source context position last effective_axis env fncs ns)
Ast "for" [Avar var,Avar ivar,source,body]
-> let p = maxPosition (Avar ivar) body
ts = 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 ns)++r)
[] (eval ts context position last effective_axis env fncs ns) 1
Ast "sortTuple" (exp:orderBys)
-> let ee = eval exp context position last effective_axis env fncs ns
in [ XElem (QName "" "" "") [] 0 parent_error
(foldl (\r a -> r++[XElem (QName "" "" "") [] 0 parent_error
(toData (eval a context position last effective_axis env fncs ns))])
[XElem (QName "" "" "") [] 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 ns)
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)
Ast "type" [tp]
-> [ XType (toType tp ns) ]
_ -> error ("Illegal XQuery: "++show e)
type Statements = [(String,Statement)]
applyPredicatesM :: [Ast] -> XSeq -> Environment -> Functions -> NS -> Connection -> Statements -> IO XSeq
applyPredicatesM preds xs env fncs ns db stmts
= foldl' (\s p -> s >>= \r -> applyPred r p True) (return xs) preds
where applyPred [] _ _ = return []
applyPred xs (Aint n) _
= return $! index xs (n1)
applyPred xs (Ast "call" [Avar "last"]) _
= return $! [ last xs ]
applyPred xs pred True
| pos > 0
= applyPred (take pos xs) pred False
where pos = maxPosition pathPosition pred
applyPred xs pred _
| containsLast pred
= let last = length xs
in foldir (\x i r -> do vs <- evalM pred x i last "" env fncs ns db stmts
s <- r
return $! (if case vs of
[XInt k] -> k == i
b -> conditionTest b
then x:s else s))
(return []) xs 1
applyPred xs pred _
= foldir (\x i r -> do vs <- evalM pred x i undefv3 "" env fncs ns db stmts
s <- r
return $! (if case vs of
[XInt k] -> k == i
b -> conditionTest b
then x:s else s))
(return []) xs 1
evalM :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> NS -> Connection -> Statements -> IO XSeq
evalM e context position last effective_axis env fncs ns db stmts
= case e of
Avar "." -> return $! [ context ]
Avar v -> return $! (findV v env)
Ast "global" [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 ns)
Ast "context" [v,Astring dp,body]
-> do vs <- evalM v context position last effective_axis env fncs ns db stmts
foldr (\x r -> (liftM2 (++)) (evalM body x position last dp env fncs ns 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 <- downloadFile file
return $! [materialize False (parseDocument doc)]
Ast "call" [Avar "debug",c]
-> do ec <- evalM c context position last effective_axis env fncs ns db stmts
debugSession ec env fncs ns [] db
Ast "call" [Avar "eval",x]
-> do xc <- evalM x context position last effective_axis env fncs ns db stmts
case xc of
[ XText q ] -> do (res,_,_,_,_) <- evalQueryM (parse (scan q)) env fncs ns [] db False False
return res
_ -> error $ "The eval argument must be a string: " ++ show xc
Ast "step" (Avar "child":tag:Avar ".":preds)
| effective_axis /= ""
-> evalM (Ast "step" (Avar effective_axis:tag:Avar ".":preds)) context position last "" env fncs ns db stmts
Ast "step" (Avar "descendant_any":Ast "tags" tags:e:preds)
-> do vs <- evalM e context position last effective_axis env fncs ns db stmts
let ts = map (\(Avar n) -> tag n ns) tags
case vs of
[XNull] -> return vs
_ -> foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (descendant_any_with_tagged_children ts x)
env fncs ns db stmts) r)
(return []) vs
Ast "step" (Avar step:Astring n:e:preds)
-> let step_fnc = findV step pathFunctions
tagname = tag n ns
in do vs <- evalM e context position last effective_axis env fncs ns db stmts
case vs of
[XNull] -> return vs
_ -> foldr (\x r -> (liftM2 (++)) (applyPredicatesM preds (step_fnc tagname x)
env fncs ns db stmts) r)
(return []) vs
Ast "filter" (e:preds)
-> do vs <- evalM e context position last effective_axis env fncs ns db stmts
applyPredicatesM preds vs env fncs ns db stmts
Ast "predicate" [condition,body]
-> do eb <- evalM condition undefv1 undefv2 undefv3 "" env fncs ns db stmts
if conditionTest eb
then evalM body context position last effective_axis env fncs ns db stmts
else return []
Ast "executeSQL" [Avar var,args]
-> do as <- evalM args context position last effective_axis env fncs ns db stmts
executeSQL (findV var stmts) as
Ast "append" args
-> (liftM appendText) (mapM (\x -> evalM x context position last effective_axis env fncs ns db stmts) args)
Ast "if" [c,t,e]
-> do ce <- evalM c context position last effective_axis env fncs ns db stmts
evalM (if conditionTest ce then t else e) context position last effective_axis env fncs ns db stmts
Ast "validate" [e]
-> do vs <- evalM e context position last effective_axis env fncs ns db stmts
case validateXSeq vs ns of
Success xs -> return vs
Failure ts -> error ("Failed to validate the XML element: "++show ts)
Ast "insert" [e1,e2]
-> do v1 <- evalM e1 context position last effective_axis env fncs ns db stmts
v2 <- evalM e2 context position last effective_axis env fncs ns db stmts
insertDB db v1 v2
Ast "delete" [e]
-> do v <- evalM e context position last effective_axis env fncs ns db stmts
deleteDB db v
Ast "replace" [e1,e2]
-> do v1 <- evalM e1 context position last effective_axis env fncs ns db stmts
v2 <- evalM e2 context position last effective_axis env fncs ns db stmts
replaceDB db v1 v2
Ast "call" (v@(Avar fname):args)
-> do vs <- mapM (\a -> evalM a context position last effective_axis env fncs ns db stmts) args
let fn = functionTag fname ns
t = tag fname ns
if uri t == xsNamespace && isBuildInType (localName t) && length vs == 1
then return $! castAs (head vs) (TBase t)
else case filter (\(n,_,_,_,_) -> n == localName fn) systemFunctions of
[] -> case filter (\(n,_,_,_) -> n == fn) fncs of
(_,params,body,_):_
-> if (length params) == (length args)
then let is = show $ length env
in evalM body context undefv2 undefv3 ""
((zip params vs)++env) fncs ns db stmts
else error ("Wrong number of arguments in function call: "++fname)
_ -> error ("Undefined function: "++fname)
fs -> case filter (\(_,len,_,_,_) -> len < 0 || length args == len) fs of
[] -> error ("wrong number of arguments in function call: " ++ fname)
(_,_,_,f,_):_ -> return $ f vs
Ast "construction" [tag,id,parent,Ast "attributes" al,body]
-> do ct <- evalM tag context position last effective_axis env fncs ns db stmts
bc <- evalM body context position last effective_axis env fncs ns db stmts
let (as,bs) = span (\x -> case x of XAttr _ _ -> True; _ -> False) bc
alc <- foldM (\r (Ast "pair" [a,v])
-> do ac <- evalM a context position last effective_axis env fncs ns db stmts
vc <- evalM v context position last effective_axis env fncs ns db stmts
return $ (makeAttribute ac vc ns)++r) [] al
vidm <- evalM id context position last effective_axis env fncs ns db stmts
let vid = case vidm of
[XText vid] -> (read vid)::Int
_ -> 0
vparent <- evalM parent context position last effective_axis env fncs ns db stmts
return $! [ XElem (qName ct ns) (alc ++ [ (n,v) | XAttr n v <- as ])
vid (if null vparent then parent_error else head vparent) bs ]
Ast "attribute_construction" [name,value]
-> do n <- evalM name context position last effective_axis env fncs ns db stmts
v <- evalM value context position last effective_axis env fncs ns db stmts
return $! map (\(s,v) -> XAttr s v) (makeAttribute n v ns)
Ast "let" [Avar var,source,body]
-> do s <- evalM source context position last effective_axis env fncs ns db stmts
evalM body context position last effective_axis ((var,s):env) fncs ns db stmts
Ast "for" [Avar var,Avar "$",source,body]
-> do vs <- evalM source context position last effective_axis env fncs ns db stmts
foldr (\a r -> (liftM2 (++)) (evalM body a undefv2 undefv3 "" ((var,[a]):env) fncs ns db stmts) r)
(return []) vs
Ast "for" [Avar var,Avar ivar,source,body]
-> do let p = maxPosition (Avar ivar) body
ts = if p > 0
then Ast "step" [source,Ast "call" [Avar "<=",pathPosition,Aint p]]
else source
vs <- evalM ts context position last effective_axis env fncs ns db stmts
foldir (\a i r -> (liftM2 (++)) (evalM body a i undefv3 "" ((var,[a]):(ivar,[XInt i]):env) fncs ns db stmts) r)
(return []) vs 1
Ast "sortTuple" (exp:orderBys)
-> do vs <- evalM exp context position last effective_axis env fncs ns db stmts
os <- mapM (\a -> evalM a context position last effective_axis env fncs ns db stmts) orderBys
return $! [ XElem (QName "" "" "") [] 0 parent_error (foldl (\r a -> r++[XElem (QName "" "" "") [] 0 parent_error (toData a)])
[XElem (QName "" "" "") [] 0 parent_error vs] os) ]
Ast "sort" (exp:ordList)
-> do vs <- evalM exp context position last effective_axis env fncs ns 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))
Ast "type" [tp]
-> return [ XType (toType tp ns) ]
_ -> error ("Illegal XQuery: "++show e)
interactionSettings
= defaultSettings {
autoAddHistory = False,
historyFile = Just ".xquery_history.txt" }
evalInput :: (String -> Environment -> Functions -> NS -> Views -> IO (Environment,Functions,NS,Views))
-> Environment -> Functions -> NS -> Views -> String -> XSeq -> IO XSeq
evalInput eval es fs ns vs prompt dvalue
= runInputT interactionSettings $ loop es fs ns vs
where bracs s = (length $ filter (== '{') s) (length $ filter (== '}') s)
oneline prompt = do line <- System.Console.Haskeline.catch
(withInterrupt (getInputLine prompt))
(\Interrupt -> return $ Just "")
case line of
Nothing -> return ("quit",0)
Just t -> if t == ""
then oneline prompt
else return $! (t,bracs t)
readlines x c = do (line,bs) <- oneline ": "
if last line == '}' && bs+c == 0
then return $! (x++" "++(init line),0)
else if line == "quit"
then return $! (line,0)
else readlines (x++" "++line) (bs+c)
loop es fs ns vs
= do (line,c) <- oneline prompt
(stmt,_) <- if head line == '{'
then if last line == '}' && c==0
then return $! (init (tail line),0)
else readlines (tail line) c
else return $! (line,0)
if stmt == "quit"
then do outputStrLn $ if prompt == "> " then "Bye!" else ""
return dvalue
else if all isSpace stmt
then loop es fs ns vs
else if take 7 stmt == "return "
then do (result,_,_,_,_) <- liftIO $ handleInterrupt
(xqueryE (drop 7 stmt) es fs ns vs
(error "Cannot use database operations here") False False)
(return ([],es,fs,ns,vs))
return result
else do h <- get
put $ addHistory stmt h
(nes,nfs,nns,nvs) <- liftIO $ eval stmt es fs ns vs
loop nes nfs nns nvs
debugSession :: XSeq -> Environment -> Functions -> NS -> Views -> Connection -> IO XSeq
debugSession e env fncs ns views db
= do let se = show e
putStrLn $ "*** HXQ debugger: " ++ if null(index se 20) then se else (take 20 se) ++ " ..."
putStr $ "Local variables:"
mapM putStr (distinct $ map (\(v,_) -> " $"++v) env)
putStrLn "\nYou may evaluate any XQuery. Type ctr-D to exit and return the argument; type 'return exp' to exit and return exp."
evalInput (\s es fs ns vs -> do (result,evs,nfs,nns,nvs) <- xqueryE s es fs ns vs db False False
putXSeq result
return $ (evs,nfs,nns,nvs)) env fncs ns views "debug> " e
identify_globals :: Ast -> [String] -> Environment -> Ast
identify_globals body vars variables
= g body vars
where g e vars
= case e of
Avar v
-> if elem v vars
then e
else if memV ('_':v) variables
then Ast "global" [Avar ('_':v)]
else e
Ast "let" [Avar var,source,body]
-> Ast "let" [Avar var,g source vars,g body (var:vars)]
Ast "for" [Avar var,Avar ivar,source,body]
-> Ast "for" [Avar var,Avar ivar,g source vars,g body (var:ivar:vars)]
Ast "call" (f:args)
-> Ast "call" (f:map (\x -> g x vars) args)
Ast f args
-> Ast f (map (\x -> g x vars) args)
_ -> e
evalQueryM :: [Ast] -> Environment -> Functions -> NS -> Views -> Connection -> Bool -> Bool
-> IO (XSeq,Environment,Functions,NS,Views)
evalQueryM [] variables functions ns views db verbose typecheck
= return $! ([],variables,functions,ns,views)
evalQueryM (query:xs) variables functions ns views db verbose typecheck
= case query of
Ast "function" ((Avar f):body:ot:args)
-> do let params = map (\(Ast "pair" [Avar v,pt]) -> v) args
sig = map (\(Ast "pair" [Avar v,pt]) -> pt) args
nbody = identify_globals body params variables
opt = optimize (expandViews views nbody)
if verbose
then do putStrLn "Abstract Syntax Tree (AST):"
putStrLn (ppAst nbody)
putStrLn "Optimized AST:"
putStrLn (ppAst opt)
else return ()
evalQueryM xs variables ((functionTag f ns,params,opt,(map (\x -> toType x ns) sig,toType ot ns)):functions)
ns views db verbose typecheck
Ast "view" ((Avar f):body:args)
-> let params = map (\(Avar v) -> v) args
nbody = identify_globals body params variables
in evalQueryM xs variables functions ns ((f,params,nbody):views) db verbose typecheck
Ast "schema" [Avar "default-element",Astring uri]
-> evalQueryM xs variables functions ns{defaultElementNS=uri} views db verbose typecheck
Ast "schema" [Avar "default-function",Astring uri]
-> evalQueryM xs variables functions ns{defaultFunctionNS=uri} views db verbose typecheck
Ast "schema" [Avar p,Astring v]
-> let ns' = ns { prefixes = case lookup p predefinedNamespaces of
Just uri
-> if uri == v
then (p,v):prefixes ns
else error ("You cannot redefine the system namespace "++p)
_ -> (p,v):prefixes ns }
in evalQueryM xs variables functions ns' views db verbose typecheck
Ast "import" (Avar "default-element":Astring uri:xschemas)
-> do ss <- mapM (\(Astring t) -> parseSchema t ns) xschemas
evalQueryM xs variables functions
ns { defaultElementNS=uri,
prefixes=(uri,uri):(prefixes ns),
schemas=(uri,concat ss):(schemas ns) }
views db verbose typecheck
Ast "import" (Avar "default-function":Astring uri:xschemas)
-> do ss <- mapM (\(Astring t) -> parseSchema t ns) xschemas
evalQueryM xs variables functions
ns { defaultFunctionNS=uri,
prefixes=(uri,uri):(prefixes ns),
schemas=(uri,concat ss):(schemas ns) }
views db verbose typecheck
Ast "import" (Avar p:Astring v:xschemas)
-> do ss <- mapM (\(Astring t) -> parseSchema t ns) xschemas
let ns' = ns { prefixes = case lookup p predefinedNamespaces of
Just uri
-> if uri == v
then (p,v):prefixes ns
else error ("You cannot redefine the system namespace "++p)
_ -> (p,v):prefixes ns,
schemas=(v,concat ss):(schemas ns) }
evalQueryM xs variables functions ns' views db verbose typecheck
Ast "variable" [Avar v,tp,u]
-> do uv <- evalM (optimize (identify_globals u [] variables))
undefv1 undefv2 undefv3 "" variables functions ns db []
if typeCheck u (toType tp ns) [] [] ns
then evalQueryM xs (('_':v,uv):variables) functions ns views db verbose typecheck
else error("Value does not match type in "++show query)
_ -> do let opt = optimize (expandViews views (identify_globals query [] variables))
(ast,nss) = liftIOSources opt
if verbose
then do putStrLn "Abstract Syntax Tree (AST):"
putStrLn (ppAst query)
putStrLn "Optimized AST:"
putStrLn (ppAst (foldl (\r (n,_,e) -> Ast "let" [Avar n,
case e of Astring _ -> Ast "doc" [e]; _ -> e,r]) ast nss))
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 <- downloadFile file
env <- r
return $! ((n,[materialize b (parseDocument doc)]):env)
_ -> r)
(return []) nss
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 []) nss
if typecheck
then do let tp = typeInference opt [] (map (\(n,_,_,s) -> (show n,s)) functions) ns
putStrLn $ "Type: " ++ show tp
else return ()
result <- evalM ast undefv1 undefv2 undefv3 "" (env++variables) functions ns db stmts
(rest,renv,rfuns,ns',rviews) <- evalQueryM xs variables functions ns views db verbose typecheck
return $! (result++rest,renv,rfuns,ns',rviews)
xqueryE :: String -> Environment -> Functions -> NS -> Views -> Connection -> Bool -> Bool
-> IO (XSeq,Environment,Functions,NS,Views)
xqueryE query variables functions ns views db verbose typecheck
= evalQueryM (parse (scan query)) variables functions ns views db verbose typecheck
xquery :: String -> IO XSeq
xquery query = do (u,_,_,_,_) <- xqueryE query [] [] initialNS []
(error "No database connectivity") False False
return $! u
xqueryDB :: String -> Connection -> IO XSeq
xqueryDB query db = do (u,_,_,_,_) <- xqueryE query [] [] initialNS [] db False False
return $! u
xfileDB :: String -> Connection -> IO XSeq
xfileDB file db = do query <- readFile file
xqueryDB query db