{-------------------------------------------------------------------------------------
-
- The XQuery Interpreter
- Programmer: Leonidas Fegaras
- Email: fegaras@cse.uta.edu
- Web: http://lambda.uta.edu/
- Creation: 03/22/08, last update: 09/29/09
- 
- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.
- This material is provided as is, with absolutely no warranty expressed or implied.
- Any use is at your own risk. Permission is hereby granted to use or copy this program
- for any purpose, provided the above notices are retained on all copies.
-
--------------------------------------------------------------------------------------}


module 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


-- run-time bindings of FLOWR variables
type Environment = [(String,XSeq)]


-- a user-defined function is (fname,parameters,body,signature)
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()"


-- Each XPath predicate must calculate position() and last() from its input XSeq
-- if last() is used, then the evaluation is blocking (need to store the whole input XSeq)
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) _           -- shortcut that improves laziness
                = index xs (n-1)
            applyPred xs (Ast "call" [Avar "last"]) _
                = [ last xs ]
            applyPred xs pred True            -- top-k like
                | pos > 0
                = applyPred (take pos xs) pred False
                  where pos = maxPosition pathPosition pred
            applyPred xs pred _
                | containsLast pred           -- blocking: use only when last() is used in the predicate
                = 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               -- indexing
                                         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                  -- indexing
                                      b -> if conditionTest b then x:r else r) [] xs 1


-- The XQuery interpreter
-- context: context node (XPath .)
-- position: the element position in the parent sequence (XPath position())
-- last: the length of the parent sequence (XPath last())
-- effective_axis: the XPath axis in /axis::tag(exp)
--        eg, the effective axis of //(A | B) is descendant
-- env: contains FLOWR variable bindings
-- fncs: user-defined functions
-- ns: namespaces
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]      -- blocking
          -> 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) (showsXS 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]      -- a for-loop without an index
          -> 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]     -- a for-loop with an index
          -> let p = maxPosition (Avar ivar) body
                 ts = if p > 0              -- there is a top-k like restriction
                      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)             -- prepare each FLWOR tuple for sorting
          -> 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)                   -- blocking
          -> 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)]


-- The monadic applyPredicates that propagates IO state
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) _           -- shortcut that improves laziness
                = return $! index xs (n-1)
            applyPred xs (Ast "call" [Avar "last"]) _
                = return $! [ last xs ]
            applyPred xs pred True            -- top-k like
                | pos > 0
                = applyPred (take pos xs) pred False
                  where pos = maxPosition pathPosition pred
            applyPred xs pred _
                | containsLast pred           -- blocking: use only when last() is used in the predicate
                = 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            -- indexing
                                                          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               -- indexing
                                                       b -> conditionTest b
                                                  then x:s else s))
                         (return []) xs 1


-- The monadic XQuery interpreter; it is like eval but has plumbing to propagate IO state
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 ]
      -- for non-IO XQuery, use the regular eval
      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]     -- this is the only lazy function
          -> 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)        -- Note: strict function application
          -> 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]      -- a for-loop without an index
          -> 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]     -- a for-loop with an index
          -> do let p = maxPosition (Avar ivar) body
                    ts = if p > 0              -- there is a top-k like restriction
                            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)             -- prepare each FLWOR tuple for sorting
          -> 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)                   -- blocking
          -> 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)


-- Haskeline settings
interactionSettings
    = defaultSettings {
        autoAddHistory = False,
        historyFile = Just ".xquery_history.txt" }


-- evaluate from input continuously
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


-- | Evaluate the XQuery using the interpreter.
xquery :: String -> IO XSeq
xquery query = do (u,_,_,_,_) <- xqueryE query [] [] initialNS []
                                         (error "No database connectivity") False False
                  return $! u


-- | Evaluate the XQuery with database connectivity using the interpreter.
xqueryDB :: String -> Connection -> IO XSeq
xqueryDB query db = do (u,_,_,_,_) <- xqueryE query [] [] initialNS [] db False False
                       return $! u


-- | Read an XQuery with database connectivity from a file and run it using the interpreter.
xfileDB :: String -> Connection -> IO XSeq
xfileDB file db = do query <- readFile file
                     xqueryDB query db