{-------------------------------------------------------------------------------------
-
- The XQuery Interpreter
- Programmer: Leonidas Fegaras
- Email: fegaras@cse.uta.edu
- Web: http://lambda.uta.edu/
- Creation: 03/22/08, last update: 05/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.
- 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.
-
--------------------------------------------------------------------------------------}


{-# OPTIONS_GHC -fth -fglasgow-exts #-}


module XML.HXQ.Interpreter where

import Control.Monad
import List(sortBy)
import XMLParse(parseDocument)
import System.Console.Readline
import XML.HXQ.Parser
import XML.HXQ.XTree
import XML.HXQ.Optimizer
import XML.HXQ.Compiler
import Database.HDBC
import XML.HXQ.DB
import XML.HXQ.DBConnect


-- system functions (=, concat, etc)
systemFunctions :: [(String,Int,[XSeq]->XSeq)]
systemFunctions = $(iFunctions)


-- XPath step functions (child, descendant, etc)
pathFunctions :: [(String,Tag->XTree->XSeq)]
pathFunctions = $(pFunctions)


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


-- a user-defined function is (fname,parameters,body)
type Functions = [(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 -> Bool -> Environment -> Functions -> XSeq
applyPredicates [] xs _ _ _ = xs
applyPredicates ((Aint n):preds) xs _ env fncs   -- shortcut that improves laziness
    = applyPredicates preds [xs !! (n-1)] True env fncs
applyPredicates (pred:preds) xs True env fncs    -- top-k like
    | maxPosition pathPosition pred > 0
    = applyPredicates (pred:preds) (take (maxPosition pathPosition pred) xs) False env fncs
applyPredicates (pred:preds) xs _ env fncs
    | containsLast pred         -- blocking: use only when last() is used in the predicate
    = 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               -- indexing
                                  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               -- indexing
                               b -> if conditionTest b then x:r else r) [] xs 1) True env fncs


-- 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_step"
-- env: contains FLOWR variable bindings
-- fncs: user-defined functions
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 "child_step" [tag, Avar "."]
          |  effective_axis /= ""
          -> eval (Ast effective_axis [tag, Avar "."]) context position last "" env fncs
      Ast "step" ((Ast "descendant_any" (body:tags)):predicates)
          -> let ts = map (\(Avar tag) -> tag) tags
             in foldr (\x r -> (applyPredicates predicates (descendant_any_with_tagged_children ts x) True env fncs)++r)
                      [] (eval body context position last effective_axis env fncs)
      Ast "step" ((Ast path_step [Astring tag,body]):predicates)
          |  memV path_step pathFunctions
          -> foldr (\x r -> (applyPredicates predicates ((findV path_step pathFunctions) tag x) True env fncs)++r)
                   [] (eval body context position last effective_axis env fncs)
      Ast "descendant_any" (body:tags)
          -> let ts = map (\(Avar tag) -> tag) tags
             in foldr (\x r -> (descendant_any_with_tagged_children ts x)++r)
                      [] (eval body context position last effective_axis env fncs)
      Ast path_step [Astring tag,body]
          |  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]
          -> applyPredicates [condition] (eval body context position last effective_axis env fncs) True env fncs
      Ast "append" args
          -> appendText (map (\x -> eval x context position last effective_axis env fncs) args)
      Ast "call" ((Avar fname):args)
          -> case filter (\(n,_,_) -> n == fname || ("fn:"++n) == fname) systemFunctions of
               [(_,len,f)] -> if (length args) == len
                              then f (map (\x -> eval x context position last effective_axis env fncs) args)
                              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 eval body context undefv2 undefv3 ""
                                                    ((zipWith (\p a -> (p,eval a context position last effective_axis env fncs))
                                                              params args)++env) fncs
                                           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) ]
      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
                                            vc = eval v context position last effective_axis env fncs
                                        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 ]
      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]      -- a for-loop without an index
          -> 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]     -- a for-loop with an index
          -> let p = maxPosition (Avar ivar) body
                 ns = 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)++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) ]
      Ast "sort" (exp:ordList)                   -- blocking
          -> 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))


-- The monadic applyPredicates that propagates IO state
applyPredicatesM :: [Ast] -> XSeq -> Bool -> Environment -> Functions -> IO XSeq
applyPredicatesM [] xs _ _ _ = return xs
applyPredicatesM ((Aint n):preds) xs _ env fncs   -- shortcut that improves laziness
    = applyPredicatesM preds [xs !! (n-1)] True env fncs
applyPredicatesM (pred:preds) xs True env fncs    -- top-k like
    | maxPosition pathPosition pred > 0
    = applyPredicatesM (pred:preds) (take (maxPosition pathPosition pred) xs) False env fncs
applyPredicatesM (pred:preds) xs _ env fncs
    | containsLast pred         -- blocking: use only when last() is used in the predicate
    = do let last = length xs
         vs <- foldir (\x i r -> do vs <- evalM pred x i last "" env fncs
                                    s <- r
                                    return (if case vs of
                                                 [XInt k] -> k == i               -- indexing
                                                 b -> conditionTest b
                                            then x:s else s))
                      (return []) xs 1
         applyPredicatesM preds vs True env fncs
applyPredicatesM (pred:preds) xs _ env fncs
    = do vs <- foldir (\x i r -> do vs <- evalM pred x i undefv3 "" env fncs
                                    s <- r
                                    return (if case vs of
                                                 [XInt k] -> k == i               -- indexing
                                                 b -> conditionTest b
                                            then x:s else s))
                      (return []) xs 1
         applyPredicatesM preds vs True env fncs


-- The monadic XQuery interpreter; it is like eval but has plumbing to propagate IO state
evalM :: Ast -> XTree -> Int -> Int -> String -> Environment -> Functions -> IO XSeq
evalM e context position last effective_axis env fncs
  = 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 ]
      -- for non-IO XQuery, use the regular eval
      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
                foldr (\x r -> (liftM2 (++)) (evalM body x position last dp env fncs) r)
                      (return []) vs
      Ast "call" [Avar "position"] -> return [XInt position]
      Ast "call" [Avar "last"] -> return [XInt last]
      Ast "child_step" [tag, Avar "."]
          |  effective_axis /= ""
          -> evalM (Ast effective_axis [tag, Avar "."]) context position last "" env fncs
      Ast "step" ((Ast "descendant_any" (body:tags)):predicates)
          -> do vs <- evalM body context position last effective_axis env fncs
                let ts = map (\(Avar tag) -> tag) tags
                foldr (\x r -> (liftM2 (++)) (applyPredicatesM predicates (descendant_any_with_tagged_children ts x) True env fncs) r)
                      (return []) vs
      Ast "step" ((Ast path_step [Astring tag,body]):predicates)
          |  memV path_step pathFunctions
          -> do vs <- evalM body context position last effective_axis env fncs
                foldr (\x r -> (liftM2 (++)) (applyPredicatesM predicates ((findV path_step pathFunctions) tag x) True env fncs) r)
                      (return []) vs
      Ast "descendant_any" (body:tags)
          -> do vs <- evalM body context position last effective_axis env fncs
                let ts = map (\(Avar tag) -> tag) tags
                return (foldr (\x r -> (descendant_any_with_tagged_children ts x)++r) [] vs)
      Ast path_step [Astring tag,body]
          |  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
      Ast "predicate" [condition,body]
          -> do vs <- evalM body context position last effective_axis env fncs
                applyPredicatesM [condition] vs True env fncs
      Ast "executeSQL" [Avar var,args]
          -> do as <- evalM args context position last effective_axis env fncs
                let [XStmt stmt] = findV var env
                executeSQL stmt as
      Ast "call" [Avar nm,c,t,e]     -- this is the only lazy function
          | elem nm ["if","fn:if"]
          -> do ce <- evalM c context position last effective_axis env fncs
                evalM (if conditionTest ce then t else e) context position last effective_axis env fncs
      Ast "append" args
          -> (liftM appendText) (mapM (\x -> evalM x context position last effective_axis env fncs) args)
      Ast "call" ((Avar fname):args)        -- Note: strict function application
          -> case filter (\(n,_,_) -> n == fname || ("fn:"++n) == fname) systemFunctions of
               [(_,len,f)] -> if (length args) == len
                              then (liftM f) (mapM (\x -> evalM x context position last effective_axis env fncs) args)
                              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) args
                                                   evalM body context undefv2 undefv3 ""
                                                             ((zipWith (\p a -> (p,a)) params vs)++env) fncs
                                           else error ("Wrong number of arguments in function call: "++fname)
                      _ -> 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 ]
      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
                                           vc <- evalM v context position last effective_axis env fncs
                                           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 ]
      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
      Ast "for" [Avar var,Avar "$",source,body]      -- a for-loop without an index
          -> do vs <- evalM source context position last effective_axis env fncs
                foldr (\a r -> (liftM2 (++)) (evalM body a undefv2 undefv3 "" ((var,[a]):env) fncs) r)
                      (return []) vs
      Ast "for" [Avar var,Avar ivar,source,body]     -- a for-loop with an index
          -> do let p = maxPosition (Avar ivar) body
                    ns = if p > 0              -- there is a top-k like restriction
                            then Ast "step" [source,Ast "call" [Avar "<=",pathPosition,Aint p]]
                            else source 
                vs <- evalM ns context position last effective_axis env fncs
                foldir (\a i r -> (liftM2 (++)) (evalM body a i undefv3 "" ((var,[a]):(ivar,[XInt i]):env) fncs) 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
                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) ]
      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
                    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))


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


xqueryE :: String -> Environment -> Functions -> (String -> IO XSeq) -> Bool -> IO (XSeq,Environment,Functions)
xqueryE query variables functions dbmapper verbose
    = do let asts = parse (scan query)
             fncs = foldr (\e r -> case e of
                                     Ast "function" ((Avar f):b:args) -> (f,map (\(Avar v) -> v) args,optimize b):r
                                     _ -> r) functions asts
         vars <- foldl (\r e -> case e of
                                  Ast "variable" [Avar v,u]
                                      -> do s <- r
                                            uv <- evalM (optimize u) undefv1 undefv2 undefv3 "" s fncs
                                            return ((v,uv):s)
                                  _ -> r) (return variables) asts
         let exprp e = case e of Ast f _ | elem f ["function","variable"] -> True; _ -> False
             exps = concatenateAll (dropWhile exprp asts)
             opt_exps = optimize exps
             (ast,ns) = liftIOSources opt_exps
         if verbose
            then do putStrLn "Abstract Syntax Tree (AST):"
                    putStrLn (ppAst exps)
                    putStrLn "Optimized AST:"
                    putStrLn (ppAst opt_exps)
                    putStrLn "Result:"
            else return ()
         env <- foldr (\(n,s) r -> case s of
                                     Avar m -> do env <- r
                                                  return ((n,findV m env):env)
                                     Ast "prepareSQL" [Astring sql]
                                         -> do env <- r
                                               t <- dbmapper sql
                                               return ((n,t):env)
                                     Astring file -> do doc <- readFile file
                                                        env <- r
                                                        return ((n,[materialize (parseDocument doc)]):env))
                      (return []) ns
         e <- evalM ast undefv1 undefv2 undefv3 "" (env++vars) fncs
         return (e,vars,fncs)


-- | Evaluate the XQuery using the interpreter.
xquery :: String -> IO XSeq
xquery query = do (u,_,_) <- xqueryE query [] [] (\sql -> return []) False
                  return u


-- | Read an XQuery from a file and run it using the interpreter.
xfile :: String -> IO XSeq
xfile file = do query <- readFile file
                xquery query


-- | Evaluate the XQuery with database connectivity using the interpreter.
xqueryDB :: (IConnection conn) => String -> conn -> IO XSeq
xqueryDB query db = do (u,_,_) <- xqueryE query [] []
                                  (\sql -> do stmt <- prepareSQL db sql
                                              return [XStmt stmt]) False
                       return u


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