HXQ-0.5: XQueryInterpreter.hs

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

module XQueryInterpreter where

import List(sortBy)
import XMLParse(parseDocument)
import XQueryParser
import XQueryCompiler


systemFunctions :: [(String,Int,[XSeq]->XSeq)]
systemFunctions = $(iFunctions)

type Environment = [(String,XSeq)]

-- user-defined function: (fname,parameters,body)
type Functions = [(String,[String],Ast)]


findV var env
  = case filter (\(n,_) -> n==var) env of
      (_,b):_ -> b
      _ -> error ("Undefined variable: "++var)


eval :: Ast -> Environment -> Functions -> XSeq
eval e env fncs
  = case e of
      Avar v -> findV v env
      Aint n -> [ XInt n ]
      Afloat n -> [ XFloat n ]
      Astring s -> [ XText s ]
      Ast "doc" [Aint n] -> findV ("_doc"++(show n)) env
      Ast "call" [Avar "position"] -> findV "_position" env
      Ast "call" [Avar "last"] -> findV "_last" env
      Ast "call" ((Avar fname):args)
             -> case filter (\(n,_,_) -> n==fname) systemFunctions of
                  [(_,len,f)] -> if (length args) == len
                                    then f (map (\x -> eval x 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 ((zipWith (\p a -> (p,eval a 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" al,body]
             -> let alc = map (\p -> case p of
                                       Ast "pair" [Astring a,Astring v]
                                           -> (a,v)
                                       Ast "pair" [Astring a,v]
                                           -> (a,showXS (text (eval v env fncs)))) al
                in [ XElem tag alc (eval body env fncs) ]
      Ast "predicate" [condition,body]
             |  containsLast condition      -- blocking: use only when last() is used in condition
             -> let bl = eval body env fncs
                    len = length bl
                in foldir (\x i r -> case eval condition ((".",[ x ]):("_position",[ XInt i ])
                                                                 :("_last",[ XInt len ]):env) fncs of
                                       [] -> r
                                       [XInt n] -> if i==n then x:r else r    -- indexing
                                       _ -> x:r) [] bl 1
      Ast "predicate" [condition,body]      -- non-blocking
             -> foldir (\x i r -> case eval condition ((".",[ x ]):("_position",[ XInt i ]):env) fncs of
                                    [] -> r
                                    [XInt n] -> if i==n then x:r else r    -- indexing
                                    _ -> x:r) [] (eval body env fncs) 1
      Ast "let" [Avar var,source,body]
             -> eval body ((var,eval source env fncs):env) fncs
      Ast "for" [Avar var,Avar "$",source,body]      -- a for-loop without an index
             -> foldr (\a r -> (eval body ((var,[a]):env) fncs)++r) [] (eval source env fncs)
      Ast "for" [Avar var,Avar ivar,source,body]     -- a for-loop with an index
             -> foldir (\a i r -> (eval body ((var,[a]):(ivar,[XInt i]):env) fncs)++r)
                       [] (eval source env fncs) 1
      Ast "sortTuple" (exp:orderBys)             -- prepare each FLWOR tuple for sorting
             -> [ XElem "" [] (foldl (\r a -> r++[XElem "" [] (text (eval a env fncs))])
                                     [XElem "" [] (eval exp env fncs)] orderBys) ]
      Ast "sort" (exp:ordList)
             -> let ce = map (\(XElem "" [] xs) -> map (\(XElem "" [] ys) -> ys) xs) (eval exp 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 XQuery interpreter
xquery :: String -> IO XSeq
xquery query
   = do let asts = parse (scan query)
            fncs = foldr (\e r -> case e of
                                    Ast "define" ((Avar f):b:args) -> (f,map (\(Avar v) -> v) args,optimize b):r
                                    _ -> r) [] asts 
            (ast,_,ns) = getDocs (last asts) 0
        env <- foldr (\(n,Astring file) r -> do doc <- readFile file
                                                env <- r
                                                return (("_doc"++(show n),[materialize (parseDocument doc)]):env))
                     (return []) ns
        return (eval (optimize ast) env fncs)


-- Read an XQuery fom a file and run it
xfile :: String -> IO XSeq
xfile file = do query <- readFile file
                xquery query