-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.XPath.XPathEval
   Copyright  : Copyright (C) 2006-2011 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   The core functions for evaluating the different types of XPath expressions.
   Each 'Expr'-constructor is mapped to an evaluation function.

-}

-- ------------------------------------------------------------

module Text.XML.HXT.XPath.XPathEval
    ( getXPath
    , getXPathSubTrees
    , getXPathNodeSet'

    , getXPathWithNsEnv
    , getXPathSubTreesWithNsEnv
    , getXPathNodeSetWithNsEnv'

    , evalExpr
    , addRoot'

    , parseXPathExpr
    , parseXPathExprWithNsEnv

    , getXPath'
    , getXPathSubTrees'
    , getXPathNodeSet''
    )
where

import Data.List                        ( partition )
import Data.Maybe                       ( fromJust, fromMaybe )

import Text.XML.HXT.XPath.XPathFct
import Text.XML.HXT.XPath.XPathDataTypes
import Text.XML.HXT.XPath.XPathArithmetic
                                        ( xPathAdd
                                        , xPathDiv
                                        , xPathMod
                                        , xPathMulti
                                        , xPathUnary
                                        )
import Text.XML.HXT.XPath.XPathParser   ( parseXPath )
import Text.XML.HXT.XPath.XPathToString ( xPValue2XmlTrees )
import Text.XML.HXT.XPath.XPathToNodeSet( xPValue2XmlNodeSet
                                        , emptyXmlNodeSet
                                        )

import Text.XML.HXT.Parser.XmlCharParser( withNormNewline )

import Text.ParserCombinators.Parsec    ( runParser )

-- ----------------------------------------

-- the DOM functions

import           Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN

-- ----------------------------------------

-- the list arrow functions

import Control.Arrow                    ( (>>>), (>>^), left )
import Control.Arrow.ArrowList          ( arrL, isA )
import Control.Arrow.ArrowIf            ( filterA )
import Control.Arrow.ListArrow          ( runLA )
import qualified
       Control.Arrow.ArrowTree          as AT

import Text.XML.HXT.Arrow.XmlArrow      ( ArrowDTD, isDTD, getDTDAttrl )
import Text.XML.HXT.Arrow.Edit          ( canonicalizeForXPath )

-- -----------------------------------------------------------------------------
-- |
-- Select parts of a document by a string representing a XPath expression.
--
-- The main filter for selecting parts of a document via XPath.
-- The string argument must be a XPath expression with an absolute location path,
-- the argument tree must be a complete document tree.
-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
-- are converted to text nodes.

getXPath                :: String -> XmlTree -> XmlTrees
getXPath                = getXPathWithNsEnv []

-- -----------------------------------------------------------------------------
-- |
-- Select parts of a document by an already parsed XPath expression

getXPath'               :: Expr -> XmlTree -> XmlTrees
getXPath' e             = runLA $
                          canonicalizeForXPath
                          >>>
                          arrL (getXPathValues' xPValue2XmlTrees e)

-- -----------------------------------------------------------------------------
-- |
-- Select parts of a document by a namespace aware XPath expression.
--
-- Works like 'getXPath' but the prefix:localpart names in the XPath expression
-- are interpreted with respect to the given namespace environment

getXPathWithNsEnv       :: Attributes -> String -> XmlTree -> XmlTrees
getXPathWithNsEnv env s = runLA ( canonicalizeForXPath
                                  >>>
                                  arrL (getXPathValues xPValue2XmlTrees xPathErr env s)
                                )

-- -----------------------------------------------------------------------------
-- |
-- Select parts of an XML tree by a string representing an XPath expression.
--
-- The main filter for selecting parts of an arbitrary XML tree via XPath.
-- The string argument must be a XPath expression with an absolute location path,
-- There are no restrictions on the arument tree.
--
-- No canonicalization is performed before evaluating the query
--
-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
-- are convertet to text nodes.

getXPathSubTrees                        :: String -> XmlTree -> XmlTrees
getXPathSubTrees                        = getXPathSubTreesWithNsEnv []

-- -----------------------------------------------------------------------------
-- |
-- Select parts of an XML tree by an XPath expression.

getXPathSubTrees'                       :: Expr -> XmlTree -> XmlTrees
getXPathSubTrees'                       = getXPathValues' xPValue2XmlTrees

-- -----------------------------------------------------------------------------
-- | Same as 'getXPathSubTrees' but with namespace aware XPath expression

getXPathSubTreesWithNsEnv               :: Attributes -> String -> XmlTree -> XmlTrees
getXPathSubTreesWithNsEnv nsEnv xpStr   = getXPathValues xPValue2XmlTrees xPathErr nsEnv xpStr

-- -----------------------------------------------------------------------------
-- |
-- compute the node set of an XPath query

getXPathNodeSet'                        :: String -> XmlTree -> XmlNodeSet
getXPathNodeSet'                        = getXPathNodeSetWithNsEnv' []

-- -----------------------------------------------------------------------------
-- |
-- compute the node set of an XPath query for an already parsed XPath expr

getXPathNodeSet''                       :: Expr -> XmlTree -> XmlNodeSet
getXPathNodeSet''                       = getXPathValues' xPValue2XmlNodeSet

-- -----------------------------------------------------------------------------
-- | compute the node set of a namespace aware XPath query

getXPathNodeSetWithNsEnv'               :: Attributes -> String -> XmlTree -> XmlNodeSet
getXPathNodeSetWithNsEnv' nsEnv xpStr   = getXPathValues xPValue2XmlNodeSet (const emptyXmlNodeSet) nsEnv xpStr

-- -----------------------------------------------------------------------------

-- | parse xpath, evaluate xpath expr and prepare results

getXPathValues                          :: (XPathValue -> a) -> (String -> a) -> Attributes -> String -> XmlTree -> a
getXPathValues cvRes cvErr nsEnv xpStr t
                                        = case parseXPathExprWithNsEnv nsEnv xpStr of
                                          Left  parseError      -> cvErr parseError
                                          Right xpExpr          -> getXPathValues' cvRes xpExpr t

xPathErr                                :: String -> [XmlTree]
xPathErr parseError                     = [ XN.mkError c_err parseError ]

-- -----------------------------------------------------------------------------

-- | parse xpath, evaluate xpath expr and prepare results

getXPathValues'                         :: (XPathValue -> a) -> Expr -> XmlTree -> a
getXPathValues' cvRes xpExpr t          = cvRes xpRes
    where
    t'                                  = addRoot' t                            -- we need a root node for starting xpath eval
    idAttr                              = ( ("", "idAttr")                      -- id attributes from DTD (if there)
                                          , idAttributesToXPathValue . getIdAttributes $ t'
                                          )
    navTD                               = ntree t'
    xpRes                               = evalExpr (idAttr:(getVarTab varEnv),[]) (1, 1, navTD) xpExpr (XPVNode . singletonNodeSet $ navTD)

addRoot'                                :: XmlTree -> XmlTree
addRoot' t
    | XN.isRoot t                       = t
    | otherwise                         = XN.mkRoot [] [t]

-- -----------------------------------------------------------------------------

-- | parse an XPath expr string
-- and return an expr tree or an error message.
-- Namespaces are not taken into account.

parseXPathExpr                          :: String -> Either String Expr
parseXPathExpr                          = parseXPathExprWithNsEnv []

-- | parse an XPath expr string with a namespace environment for qualified names in the XPath expr
-- and return an expr tree or an error message

parseXPathExprWithNsEnv                 :: Attributes -> String -> Either String Expr
parseXPathExprWithNsEnv nsEnv xpStr     = left fmtErr . runParser parseXPath (withNormNewline (toNsEnv nsEnv)) "" $ xpStr
    where
    fmtErr parseError                   = "Syntax error in XPath expression " ++
                                          show xpStr ++ ": " ++
                                          show parseError

-- -----------------------------------------------------------------------------

-- |
-- The main evaluation entry point.
-- Each XPath-'Expr' is mapped to an evaluation function. The 'Env'-parameter contains the set of global variables
-- for the evaluator, the 'Context'-parameter the root of the tree in which the expression is evaluated.
--

evalExpr                                :: Env -> Context -> Expr -> XPathFilter
evalExpr env cont (GenExpr Or ex)       = boolEval  env cont Or  ex
evalExpr env cont (GenExpr And ex)      = boolEval  env cont And ex
evalExpr env cont (GenExpr Eq ex)       = relEqEval env cont Eq        . evalExprL env cont ex
evalExpr env cont (GenExpr NEq ex)      = relEqEval env cont NEq       . evalExprL env cont ex
evalExpr env cont (GenExpr Less ex)     = relEqEval env cont Less      . evalExprL env cont ex
evalExpr env cont (GenExpr LessEq ex)   = relEqEval env cont LessEq    . evalExprL env cont ex
evalExpr env cont (GenExpr Greater ex)  = relEqEval env cont Greater   . evalExprL env cont ex
evalExpr env cont (GenExpr GreaterEq ex)
                                        = relEqEval env cont GreaterEq . evalExprL env cont ex
evalExpr env cont (GenExpr Plus ex)     = numEval xPathAdd   Plus  . toXValue xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Minus ex)    = numEval xPathAdd   Minus . toXValue xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Div ex)      = numEval xPathDiv   Div   . toXValue xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Mod ex)      = numEval xPathMod   Mod   . toXValue xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Mult ex)     = numEval xPathMulti Mult  . toXValue xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Unary ex)    = xPathUnary . xnumber cont env . evalExprL env cont ex
evalExpr env cont (GenExpr Union ex)    = unionEval . evalExprL env cont ex
evalExpr env cont (FctExpr name args)   = fctEval env cont name args

evalExpr env _    (PathExpr Nothing   (Just lp))
                                        = locPathEval env lp
evalExpr env cont (PathExpr (Just fe) (Just lp))
                                        = locPathEval env lp . evalExpr env cont fe

evalExpr env cont (FilterExpr ex)       = filterEval env cont ex
evalExpr env _    ex                    = evalSpezExpr env ex

-- -----------------------------------------------------------------------------

evalExprL                               :: Env -> Context -> [Expr] -> XPathValue -> [XPathValue]
evalExprL env cont ex ns                = map (\e -> evalExpr env cont e ns) ex

-- -----------------------------------------------------------------------------

evalSpezExpr                            :: Env -> Expr -> XPathFilter
evalSpezExpr _ (NumberExpr (Float 0)) _ = XPVNumber Pos0
evalSpezExpr _ (NumberExpr (Float f)) _ = XPVNumber (Float f)
evalSpezExpr _ (LiteralExpr s) _        = XPVString s
evalSpezExpr env (VarExpr name) v       = getVariable env name v
evalSpezExpr _ _ _                      = XPVError "Call to evalExpr with a wrong argument"

-- -----------------------------------------------------------------------------

-- |
-- filter for evaluating a filter-expression

filterEval                              :: Env -> Context -> [Expr] -> XPathFilter
filterEval env cont (prim:predicates) ns
                                        = case evalExpr env cont prim ns of
                                          (XPVNode nns) -> nodeListResToXPathValue . evalPredL env predicates . Right . fromNodeSet $ nns
                                          _             -> XPVError "Return of a filterexpression is not a nodeset"
filterEval _ _ _ _                      = XPVError "Call to filterEval without an expression"


-- -----------------------------------------------------------------------------
-- |
-- returns the union of its arguments, the arguments have to be node-sets.

unionEval                               :: [XPathValue] -> XPathValue
unionEval vs
    | not (null evs)                    = case head evs of
                                          e@(XPVError _)        -> e
                                          _                     -> XPVError "A value of a union ( | ) is not a nodeset"
    | otherwise                         = XPVNode . unionsNodeSet . map theNode $ nvs
    where
    (nvs, evs)                          = partition isNode vs

    isNode (XPVNode _)                  = True
    isNode _                            = False

    theNode (XPVNode ns)                = ns
    theNode _                           = error "illegal argument in unionEval"

-- -----------------------------------------------------------------------------
-- |
-- Equality or relational test for node-sets, numbers, boolean values or strings,
-- each computation of two operands is done by relEqEv'

relEqEval                               :: Env -> Context -> Op -> [XPathValue] -> XPathValue
relEqEval env cont op                   = foldl1 (relEqEv' env cont op)

relEqEv'                                :: Env -> Context -> Op -> XPathValue -> XPathFilter
relEqEv' _ _ _ e@(XPVError _) _         = e
relEqEv' _ _ _ _ e@(XPVError _)         = e

-- two node-sets

relEqEv' env cont op a@(XPVNode _)
                     b@(XPVNode _)      = relEqTwoNodes env cont op a b

-- one node-set

relEqEv' env cont op a b@(XPVNode _)    = relEqOneNode env cont (fromJust $ getOpFct op) a b
relEqEv' env cont op a@(XPVNode _) b    = relEqOneNode env cont (flip $ fromJust $ getOpFct op) b a


--  test without a node-set and equality or not-equality operator

relEqEv' env cont Eq a b                = eqEv env cont (==) a b
relEqEv' env cont NEq a b               = eqEv env cont (/=) a b

-- test without a node-set and less, less-equal, greater or greater-equal operator

relEqEv' env cont op a b                = XPVBool ((fromJust $ getOpFct op) (toXNumber a) (toXNumber b))
    where
    toXNumber x                         = xnumber cont env [x]

-- -----------------------------------------------------------------------------

-- |
-- Equality or relational test for two node-sets.
-- The comparison will be true if and only if there is a node in the first node-set
-- and a node in the second node-set such that the result of performing the
-- comparison on the string-values of the two nodes is true

relEqTwoNodes                           :: Env -> Context -> Op -> XPathValue -> XPathFilter
relEqTwoNodes _ _ op (XPVNode ns)
                     (XPVNode ms)       = XPVBool $
                                          foldr  (\n -> (any (fct op n) (getStrValues ms) ||)) False $
                                          fromNodeSet ns
                                          where
                                          fct op' n'   = (fromJust $ getOpFct op') (stringValue n')
                                          getStrValues = map stringValue . fromNodeSet
relEqTwoNodes _ _ _ _ _                 = XPVError "Call to relEqTwoNodes without a nodeset"

-- -----------------------------------------------------------------------------
-- |
-- Comparison between a node-set and different type.
-- The node-set is converted in a boolean value if the second argument is of type boolean.
-- If the argument is of type number, the node-set is converted in a number, otherwise it is converted
-- in a string value.

relEqOneNode                            :: Env -> Context ->
                                           (XPathValue -> XPathValue -> Bool) -> XPathValue -> XPathFilter

relEqOneNode env cont fct arg           = withXPVNode "Call to relEqOneNode without a nodeset" $
                                          \ ns -> XPVBool (any  (fct arg) (getStrValues arg ns))
    where
    getStrValues arg'                   = map ((fromJust $ getConvFct arg') cont env . (:[])) .
                                          map stringValue .
                                          fromNodeSet

-- -----------------------------------------------------------------------------

-- |
-- No node-set is involved and the operator is equality or not-equality.
-- The arguments are converted in a common type. If one argument is a boolean value
-- then it is the boolean type. If a number is involved, the arguments have to converted in numbers,
-- else the string type is the common type.

eqEv                                    :: Env -> Context -> (XPathValue -> XPathValue -> Bool) -> XPathValue -> XPathFilter
eqEv env cont fct f@(XPVBool _) g       = XPVBool (f `fct` xboolean cont env [g])
eqEv env cont fct f g@(XPVBool _)       = XPVBool (xboolean cont env [f] `fct` g)
eqEv env cont fct f@(XPVNumber _) g     = XPVBool (f `fct` xnumber cont env [g])
eqEv env cont fct f g@(XPVNumber _)     = XPVBool (xnumber cont env [f] `fct` g)
eqEv env cont fct f g                   = XPVBool (xstring cont env [f] `fct` xstring cont env [g])

-- -----------------------------------------------------------------------------

getOpFct                                :: Op -> Maybe (XPathValue -> XPathValue -> Bool)
getOpFct Eq                             = Just (==)
getOpFct NEq                            = Just (/=)
getOpFct Less                           = Just (<)
getOpFct LessEq                         = Just (<=)
getOpFct Greater                        = Just (>)
getOpFct GreaterEq                      = Just (>=)
getOpFct _                              = Nothing

-- -----------------------------------------------------------------------------

-- |
-- Filter for accessing the root element of a document tree

getRoot                                 :: XPathFilter
getRoot                                 = withXPVNode "Call to getRoot without a nodeset" $ getRoot'
    where
    getRoot' ns
        | nullNodeSet ns                = XPVError "Call to getRoot with empty nodeset"
        | otherwise                     = XPVNode . singletonNodeSet . getRoot'' . headNodeSet $ ns

    getRoot'' tree                      = case upNT tree of
                                          Nothing       -> tree
                                          Just t        -> getRoot'' t

-- -----------------------------------------------------------------------------

type NodeList = NavXmlTrees

type NodeListRes = Either XPathValue NodeList

nodeListResToXPathValue :: NodeListRes -> XPathValue
nodeListResToXPathValue = either id (XPVNode . toNodeSet)

nullNL  :: NodeListRes
nullNL  = Right []

plusNL  :: NodeListRes -> NodeListRes -> NodeListRes
plusNL res@(Left _) _                   = res
plusNL _            res@(Left _)        = res
plusNL (Right ns1)  (Right ns2)         = Right $ ns1 ++ ns2

sumNL   :: [NodeListRes] -> NodeListRes
sumNL   = foldr plusNL nullNL

mapNL   :: (NavXmlTree -> NodeListRes) -> NodeListRes -> NodeListRes
mapNL _ res@(Left _)    = res
mapNL f (Right ns)      = sumNL . map f $ ns

mapNL'  :: (Int -> NavXmlTree -> NodeListRes) -> NodeListRes -> NodeListRes
mapNL' _ res@(Left _)   = res
mapNL' f (Right ns)     = sumNL . zipWith f [1..] $ ns

-- ------------------------------------------------------------

-- |
-- Filter for accessing all nodes of a XPath-axis
--
--    * 1.parameter as :  axis specifier
--

getAxisNodes                            :: AxisSpec ->  NodeSet -> [NodeListRes]
getAxisNodes as                         =  map (Right . (fromJust $ lookup as axisFctL)) . fromNodeSet

-- |
-- Axis-Function-Table.
-- Each XPath axis-specifier is mapped to the corresponding axis-function

axisFctL                                :: [(AxisSpec, (NavXmlTree -> NavXmlTrees))]
axisFctL                                = [ (Ancestor           , ancestorAxis)
                                          , (AncestorOrSelf     , ancestorOrSelfAxis)
                                          , (Attribute          , attributeAxis)
                                          , (Child              , childAxis)
                                          , (Descendant         , descendantAxis)
                                          , (DescendantOrSelf   , descendantOrSelfAxis)
                                          , (Following          , followingAxis)
                                          , (FollowingSibling   , followingSiblingAxis)
                                          , (Parent             , parentAxis)
                                          , (Preceding          , precedingAxis)
                                          , (PrecedingSibling   , precedingSiblingAxis)
                                          , (Self               , selfAxis)
                                          ]

-- -----------------------------------------------------------------------------
-- |
-- evaluates a location path,
-- evaluation of an absolute path starts at the document root,
-- the relative path at the context node

locPathEval                             :: Env -> LocationPath -> XPathFilter
locPathEval env (LocPath Rel steps)     = evalSteps env steps
locPathEval env (LocPath Abs steps)     = evalSteps env steps . getRoot


-- -----------------------------------------------------------------------------

evalSteps                               :: Env -> [XStep] -> XPathFilter
evalSteps env steps ns                  = foldl (flip $ evalStep env) ns steps

-- |
-- evaluate a single XPath step
-- namespace-axis is not supported

evalStep                                :: Env -> XStep -> XPathFilter

evalStep _   (Step Namespace _  _ ) _   = XPVError "namespace-axis not supported"
evalStep _   (Step Attribute nt _ ) ns  = withXPVNode "Call to getAxis without a nodeset"
                                          evalAttr'
                                          ns
    where
      evalAttr' = nodeListResToXPathValue . sumNL . map (evalAttr nt) . getAxisNodes Attribute

evalStep env (Step axisSpec  nt pr) ns  = withXPVNode "Call to getAxis without a nodeset"
                                          evalSingleStep
                                          ns
    where
      evalSingleStep = nodeListResToXPathValue . sumNL . map (evalStep' env pr nt) . getAxisNodes axisSpec

-- -----------------------------------------------------------------------------

-- the goal:
-- evalAttr                                :: NodeTest -> NavXmlTrees -> XPathValue

evalAttr                                :: NodeTest -> NodeListRes -> NodeListRes
evalAttr nt                             =  mapNL (Right . evalAttrNodeTest nt)

evalAttrNodeTest                        :: NodeTest -> NavXmlTree -> NavXmlTrees
evalAttrNodeTest (NameTest qn)
                 ns@(NT (NTree (XAttr qn1) _) _ix _ _ _)
                                        = if ( ( uri == uri1               && lp == lp1)
                                               ||
                                               ((uri == "" || uri == uri1) && lp == "*")
                                             )
                                          then [ns]
                                          else []
    where
    uri                                 = namespaceUri qn
    uri1                                = namespaceUri qn1
    lp                                  = localPart    qn
    lp1                                 = localPart    qn1

evalAttrNodeTest (TypeTest XPNode)
                 ns@(NT (NTree (XAttr _) _) _ix _ _ _)
                                        = [ns]
evalAttrNodeTest _ _                    = []

-- -----------------------------------------------------------------------------

evalStep'                               :: Env -> [Expr] -> NodeTest -> NodeListRes -> NodeListRes
evalStep' env pr nt                     = evalPredL env pr . nodeTest nt

evalPredL                               :: Env -> [Expr] -> NodeListRes -> NodeListRes
evalPredL env pr ns                     = foldl (flip $ evalPred env) ns pr

evalPred                                :: Env -> Expr -> NodeListRes -> NodeListRes
evalPred _   _  res@(Left _)            = res
evalPred env ex arg@(Right ns)          = mapNL' (evalPred' env ex (length ns)) arg 

evalPred'                               :: Env -> Expr -> Int -> Int -> NavXmlTree -> NodeListRes
evalPred' env ex len pos x              = case testPredicate env (pos, len, x) ex (XPVNode . singletonNodeSet $ x) of
                                          e@(XPVError _) -> Left e
                                          XPVBool True   -> Right [x]
                                          XPVBool False  -> Right []
                                          _              -> Left $ XPVError "Value of testPredicate is not a boolean"

testPredicate                                   :: Env -> Context -> Expr -> XPathFilter
testPredicate env context@(pos, _, _) ex ns
                                        = case evalExpr env context ex ns of
                                          XPVNumber (Float f) -> XPVBool (f == fromIntegral pos)
                                          XPVNumber _         -> XPVBool False
                                          _                   -> xboolean context env [evalExpr env context ex ns]

-- -----------------------------------------------------------------------------
-- |
-- filter for selecting a special type of nodes from the current fragment tree
--
-- the filter works with namespace activated and without namespaces.
-- If namespaces occur in XPath names, the uris are used for matching,
-- else the name prefix
--
--    Bugfix : "*" (or any other name-test) must not match the root node

nodeTest                                :: NodeTest -> NodeListRes -> NodeListRes
nodeTest _ res@(Left _)                 = res
nodeTest t (Right ns)                   = Right . nodeTest' t $ ns

nodeTest'                               :: NodeTest -> NodeList -> NodeList
nodeTest' (NameTest q)
    | isWildcardTest                    = filterNodes' (wildcardTest q)
    | otherwise                         = filterNodes' (nameTest     q)
      where
      isWildcardTest                    = localPart q == "*"

nodeTest' (PI n)                        = filterNodes' isPiNode
                                          where
                                          isPiNode = maybe False ((== n) . qualifiedName) . XN.getPiName

nodeTest' (TypeTest t)                  = typeTest t

-- |
-- the filter selects the NTree part of a navigable tree and
-- tests whether the node is of the necessary type
--
--    * 1.parameter fct :  filter function from the XmlTreeFilter module which tests the type of a node

filterNodes'                            :: (XNode -> Bool) -> NodeList -> NodeList
filterNodes' fct                        = filter (fct . dataNT)

-- -----------------------------------------------------------------------------

nameTest                                :: QName -> XNode -> Bool
nameTest xpName (XTag elemName _)
    | namespaceAware                    = localPart xpName == localPart elemName
                                          &&
                                          namespaceUri  xpName == namespaceUri  elemName
    | otherwise                         = qualifiedName xpName == qualifiedName elemName
    where
    namespaceAware                      = not . null . namespaceUri $ xpName

nameTest _ _                            = False

-- -----------------------------------------------------------------------------

wildcardTest                            :: QName -> XNode -> Bool
wildcardTest xpName (XTag elemName _)
    | namespaceAware                    = namespaceUri xpName == namespaceUri elemName
    | prefixMatch                       = namePrefix   xpName == namePrefix   elemName
    | otherwise                         = localPart  elemName /= t_root                 -- all names except the root name "/"
    where
    namespaceAware                      = not . null . namespaceUri $ xpName
    prefixMatch                         = not . null . namePrefix   $ xpName

wildcardTest _ _                        = False

-- -----------------------------------------------------------------------------
-- |
-- tests whether a node is of a special type
--
typeTest                                :: XPathNode -> NodeList -> NodeList
typeTest XPNode                         = id
typeTest XPCommentNode                  = filterNodes' XN.isCmt
typeTest XPPINode                       = filterNodes' XN.isPi
typeTest XPTextNode                     = filterNodes' XN.isText

-- -----------------------------------------------------------------------------
-- |
-- evaluates a boolean expression, the evaluation is non-strict

boolEval                                :: Env -> Context -> Op -> [Expr] -> XPathFilter
boolEval _ _ op [] _                    = XPVBool (op == And)
boolEval env cont Or (x:xs) ns          = case xboolean cont env [evalExpr env cont x ns] of
                                          e@(XPVError _) -> e
                                          XPVBool True   -> XPVBool True
                                          _              -> boolEval env cont Or xs ns

boolEval env cont And (x:xs) ns         = case xboolean cont env [evalExpr env cont x ns] of
                                          e@(XPVError _) -> e
                                          XPVBool True   -> boolEval env cont And xs ns
                                          _              -> XPVBool False
boolEval _ _ _ _ _                      = XPVError "Call to boolEval with a wrong argument"


-- -----------------------------------------------------------------------------
-- |
-- returns the value of a variable
getVariable                             :: Env -> VarName -> XPathFilter
getVariable env name _                  = fromMaybe (XPVError ("Variable: " ++ show name ++ " not found")) $
                                          lookup name (getVarTab env)


-- -----------------------------------------------------------------------------
-- |
-- evaluates a function,
-- computation is done by 'XPathFct.evalFct' which is defined in "XPathFct".

fctEval                                 :: Env -> Context -> FctName -> [Expr] -> XPathFilter
fctEval env cont name args              = evalFct name env cont . evalExprL env cont args

-- -----------------------------------------------------------------------------
-- |
-- evaluates an arithmetic operation.
--
--   1.parameter f :  arithmetic function from "XPathArithmetic"
--
numEval                                 :: (Op -> XPathValue -> XPathValue -> XPathValue) ->
                                           Op -> [XPathValue] -> XPathValue
numEval f op                            = foldl1 (f op)

-- -----------------------------------------------------------------------------
-- |
-- Convert list of ID attributes from DTD into a space separated 'XPVString'
--

idAttributesToXPathValue                :: XmlTrees -> XPathValue
idAttributesToXPathValue ts             = XPVString (foldr (\ n -> ( (valueOfDTD a_value n ++ " ") ++)) [] ts)

-- -----------------------------------------------------------------------------
-- |
-- Extracts all ID-attributes from the document type definition (DTD).
--

getIdAttributes                         :: XmlTree -> XmlTrees
getIdAttributes                         = runLA $
                                          AT.getChildren
                                          >>>
                                          isDTD
                                          >>>
                                          AT.deep (isIdAttrType)

-- ----------------------------------------

isIdAttrType                            :: ArrowDTD a => a XmlTree XmlTree
isIdAttrType                            = hasDTDAttrValue a_type (== k_id)

valueOfDTD                              :: String -> XmlTree -> String
valueOfDTD n                            = concat . runLA ( getDTDAttrl >>^ lookup1 n )

hasDTDAttrValue                         :: ArrowDTD a => String -> (String -> Bool) -> a XmlTree XmlTree
hasDTDAttrValue an p                    = filterA $
                                          getDTDAttrl >>> isA (p . lookup1 an)

-- ------------------------------------------------------------