{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}

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

{- |
   Module     : Text.XML.HXT.XPath.XPathFct
   Copyright  : Copyright (C) 2008 Uwe Schmidt
   License    : MIT

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

   The module contains the core-functions of the XPath function library.
   All functions are implemented as XFct. Each XFct contains the evaluation context,
   the variable environment and the function arguments.

-}

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

module Text.XML.HXT.XPath.XPathFct
    ( XFct
    , evalFct
    , toXValue
    , xnumber
    , xboolean
    , xstring
    , getConvFct
    , stringValue
--    , remDups
    , isNotInNodeList
{-
    , createDocumentOrder
    , createDocumentOrderReverse
-}
    , getVarTab
    , getKeyTab
    )
where

import Text.XML.HXT.XPath.XPathDataTypes
import Text.XML.HXT.XPath.XPathParser
    ( parseNumber
    )
import Text.XML.HXT.XPath.XPathArithmetic
    ( xPathAdd
    )

import Control.Arrow                            ( (>>>), (<+>) )
import Control.Arrow.ArrowList                  ( constA )
import Control.Arrow.ArrowIf                    ( ifA )
import Control.Arrow.ArrowTree                  ( deep )
import Control.Arrow.ListArrow                  ( LA, runLA )

import Text.XML.HXT.Arrow.XmlArrow
import Text.XML.HXT.Arrow.ReadDocument          ( readDocument )
import Text.XML.HXT.Arrow.XmlState              ( runX
                                                , withValidate
                                                , no
                                                )

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

import System.IO.Unsafe                         ( unsafePerformIO
                                                )

import Data.Char                                ( isAscii
                                                , isUpper
                                                , isLower
                                                , isDigit
                                                , ord
                                                )

import Data.Maybe

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

-- added by Tim Walkenhorst to fix Pos0 vs. Float 0.0 problems...

int2XPNumber :: Int -> XPNumber
int2XPNumber 0 = Pos0
int2XPNumber i = Float $ fromIntegral i

-- |
-- Type signature for all functions which can be used in the XPath module.

type XFct = (Context -> Env -> [XPathValue] -> XPathValue)

-- |
-- All functions are stored in a function table.

type FctTable = [(FctName, FctTableElem)]

-- |
-- Each table entry consists of the function and the expected function arguments.

type FctTableElem = (XFct, CheckArgCount)

-- |
-- Tests whether the number of current function arguments is correct

type CheckArgCount = ([XPathValue] -> Bool)

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

zero
 , zeroOrOne
 , one
 , two
 , twoOrM
 , twoOrThree
 , three :: CheckArgCount

zero ex       = length ex == 0
zeroOrOne ex  = length ex == 0 || length ex == 1
one ex        = length ex == 1
two ex        = length ex == 2
twoOrM ex     = length ex >= 2
twoOrThree ex = length ex == 2 || length ex == 3
three ex      = length ex == 3


-- -----------------------------------------------------------------------------
-- |
-- The core-functions library

fctTable :: FctTable
fctTable = [
            ("last", (xlast, zero)), -- nodeset functions
            ("position",(xposition, zero)),
            ("count",(xcount, one)),
            ("id", (xid, one)),
            ("local-name", (xlocalName, zeroOrOne)),
            ("namespace-uri", (xnamespaceUri, zeroOrOne)),
            ("name", (xname, zeroOrOne)),

            ("string", (xstring, zeroOrOne)), -- string functions
            ("concat", (xconcat, twoOrM)),
            ("starts-with",(xstartsWith, two)),
            ("contains", (xcontains, two)),
            ("substring-before", (xsubstringBefore, two)),
            ("substring-after", (xsubstringAfter, two)),
            ("substring", (xsubstring, twoOrThree)),
            ("string-length", (xstringLength, zeroOrOne)),
            ("normalize-space", (xnormalizeSpace, zeroOrOne)),
            ("translate", (xtranslate, three)),

            ("boolean", (xboolean, one)), -- boolean functions
            ("not", (xnot, one)),
            ("true", (xtrue, zero)),
            ("false",(xfalse, zero)),
            ("lang", (xlang, one)),

            ("number",(xnumber, zeroOrOne)), -- number functions
            ("sum",(xsum, one)),
            ("floor",(xfloor, one)),
            ("ceiling",(xceiling, one)),
            ("round",(xround, one)),
            ("key",(xkey, two)),
            ("format-number",(xformatNumber, twoOrThree)),

            ("document", (xdocument, one)),-- extension functions for xslt 1.0
            ("generate-id", (xgenerateId, zeroOrOne))

           ]

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

-- some helper functions

-- |
-- Returns the table of keys, needed by xslt, from the environment

getKeyTab :: Env -> KeyTab
getKeyTab (_, keyTab) = keyTab


-- -----------------------------------------------------------------------------
-- |
-- Returns the table of variables from the environment

getVarTab :: Env -> VarTab
getVarTab (varTab, _) = varTab


-- -----------------------------------------------------------------------------
-- |
-- Returns the conversion function for the XPath results: string, boolean and number
-- A nodeset can not be converted.

getConvFct :: XPathValue -> Maybe XFct
getConvFct (XPVNumber _) = Just xnumber
getConvFct (XPVString _) = Just xstring
getConvFct (XPVBool _)   = Just xboolean
getConvFct _             = Nothing

-- -----------------------------------------------------------------------------
-- |
-- Check whether a node is not a part of a node list. Needed to implement matching & testing in xslt.

isNotInNodeList :: NavXmlTree -> [NavXmlTree] -> Bool
isNotInNodeList n xs' = nodeID' n `notElem` map nodeID' xs'

-- -----------------------------------------------------------------------------
-- |
-- calculate an ID for a NODE
--
--    - returns : a list of numbers, one number for each level of the tree

-- Tim Walkenhorst:
--   - Attributes are identified by their QName (they do not have previous siblings)
--   - Elements are identified by their relative position (# of previous siblings)

data IdPathStep         = IdRoot String
                        | IdPos Int
                        | IdAttr QName
                          deriving (Show, Eq)

nodeID                  :: Maybe NavXmlTree -> [IdPathStep]
nodeID                  = maybe [] nodeID'

nodeID'                 :: NavXmlTree -> [IdPathStep]
nodeID' t@(NT (NTree (XAttr qn) _) _ix _ _ _)
                        = IdAttr qn : nodeID (upNT t)

nodeID' t@(NT node ix _ _ _)
   | XN.isRoot node     = return $ IdRoot (getRootId node)
   | otherwise          = IdPos ix : nodeID (upNT t)
   where
   getRootId            = concat . runLA (getAttrValue "rootId")

-- -----------------------------------------------------------------------------
-- |
-- Evaluates a function.
-- Calculation of the function value is done by looking up the function name in the function table,
-- check the number of arguments and calculate the funtion, if no
-- argument evaluation returns an error.
--
--    - returns : the function value as 'XPathValue'

evalFct :: FctName -> Env -> Context -> [XPathValue] -> XPathValue
evalFct name env cont args
    = case (lookup name fctTable) of
        Nothing -> XPVError ("Call to undefined function "++ name)
        Just (fct, checkArgCount) ->
          if not (checkArgCount args)
            then XPVError ("Call to function "++ name ++ " with wrong arguments")
            else case (checkArgErrors args) of
                   Just e  -> e
                   Nothing -> fct cont env args
      where
      checkArgErrors [] = Nothing
      checkArgErrors ((XPVError r):_) = Just (XPVError r)
      checkArgErrors (_:xs) = checkArgErrors xs


-- |
-- Converts a list of different 'XPathValue' types in a list of one 'XPathValue' type.
--
--    * 1.parameter fct :  the conversion function
--

toXValue                        :: XFct -> Context -> Env -> [XPathValue] -> [XPathValue]
toXValue fct c env args         = [fct c env [x] | x <- args]

-- -----------------------------------------------------------------------------
-- core-funktions library

-- nodeset functions

-- |
-- number last(): returns a number equal to the context size from the expression evaluation context

xlast                           :: XFct
xlast (_, len , _) _ _          = XPVNumber $ int2XPNumber len


-- -----------------------------------------------------------------------------
-- |
-- number position(): returns a number equal to the context position from the expression evaluation context

xposition                       :: XFct
xposition (pos, _ , _) _ _      = XPVNumber $ int2XPNumber pos


-- -----------------------------------------------------------------------------
-- |
-- number count(node-set): returns the number of nodes in the argument node-set

xcount                          :: XFct
xcount _ _ [XPVNode ns]         = XPVNumber . int2XPNumber . cardNodeSet $ ns
xcount _ _ _                    = XPVError "Call to function count with wrong arguments"


-- -----------------------------------------------------------------------------
-- |
-- node-set id(object): selects elements by their unique ID

xid                             :: XFct
xid (_, _, cn) env [XPVNode ns] = isInId  (getIds env) (strValues ns) [cn]
                                  where
                                  strValues = map ((\ (XPVString str) -> str) . stringValue) . fromNodeSet

xid c@(_, _, cn) env arg        = isInId (getIds env) ( (\(XPVString s) -> words s) (xstring c env arg)) [cn]



-- -----------------------------------------------------------------------------
-- |
-- returns all IDs from the variable environment as a list of strings.
-- the IDs are stored in the variable: idAttr

getIds                          :: Env -> [String]
getIds env                      = words $                       -- hier muss noch auf prefix getestet werden
                                  (\ (XPVString str) -> str) . fromJust $ lookup ("", "idAttr") $
                                  getVarTab env

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

isInId                          :: [String] -> [String] -> NavXmlTrees -> XPathValue
isInId ids str                  = XPVNode . toNodeSet . concatMap (filterNS ids str . descendantOrSelfAxis)


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

filterNS                        :: [String] -> [String] -> NavXmlTrees -> NavXmlTrees
filterNS ids str ns             = [ n | n@(NT a _ _ _ _) <- ns
                                      , or $ map (idInIdList a str) ids
                                  ]
      where
      idInIdList                :: XmlTree -> [String] -> String -> Bool
      idInIdList al str' b      = (getValue b al) `elem` str'


-- -----------------------------------------------------------------------------
-- |
-- string local-name(node-set?):
-- returns the local part of the expanded-name of the node in the argument node-set
-- that is first in document order.
-- If the argument node-set is empty or the first node has no expanded-name, an empty string is returned.
-- If the argument is omitted, it defaults to a node-set with the context node as its only member

--   Bugfix: name(\/) is "" not "\/"!

xlocalName                      :: XFct
xlocalName (_, _, cn) _ []      = XPVString (xpLocalPartOf . subtreeNT $ cn)
xlocalName _ _ [XPVNode ns]
    | nullNodeSet ns            = XPVString ""
    | otherwise                 = XPVString (xpLocalPartOf . subtreeNT . headNodeSet $ ns)
xlocalName _ _ _                = XPVError "Call to function local-name with wrong arguments"

-- -----------------------------------------------------------------------------
-- |
-- string namespace-uri(node-set?):
-- returns the namespace URI of the expanded-name of the node in the argument node-set
-- that is first in document order.
-- If the argument node-set is empty, the first node has no expanded-name,
-- or the namespace URI of the expanded-name
-- is null, an empty string is returned. If the argument is omitted,
-- it defaults to a node-set with the context node as its only member

xnamespaceUri                   :: XFct
xnamespaceUri (_, _, cn) _ []   = XPVString (xpNamespaceOf . subtreeNT $ cn)
xnamespaceUri _ _ [XPVNode ns]
    | nullNodeSet ns            = XPVString ""
    | otherwise                 = XPVString (xpNamespaceOf . subtreeNT . headNodeSet $ ns)
xnamespaceUri _ _ _             = XPVError "Call to function namespace-uri with wrong arguments"


-- -----------------------------------------------------------------------------
-- |
-- string name(node-set?):
-- returns a string containing a QName representing the expanded-name of the node
-- in the argument node-set
-- that is first in document order. If the argument node-set is empty or the first
-- node has no expanded-name,
-- an empty string is returned. If the argument it omitted, it defaults to a node-set
-- with the context node as its only member.
-- Tim Walkenhorst:

--   Bugfix: name(\/) is "" not "\/"!

xname                           :: XFct
xname (_, _, cn) _ []           = XPVString (xpNameOf . subtreeNT $ cn)
xname _ _ [XPVNode ns]
    | nullNodeSet ns            = XPVString ""
    | otherwise                 = XPVString (xpNameOf . subtreeNT . headNodeSet $ ns)
xname _ _ _                     = XPVError "Call to function name with wrong arguments"

-- ------------------------------------------------------------
-- string functions

-- |
-- some helper functions
getFirstPos                     :: String -> String -> Int
getFirstPos s sub               = if (getFirstPos' s sub) > length s
                                  then -1
                                  else getFirstPos' s sub

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

getFirstPos'                    :: String -> String -> Int
getFirstPos' [] _               = 2
getFirstPos' (x:xs) sub         = if strStartsWith (x:xs) sub
                                  then 0
                                  else 1 + getFirstPos' xs sub

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

strStartsWith                   :: String -> String -> Bool
strStartsWith a b               = take (length b) a == b

-- -----------------------------------------------------------------------------
-- |
-- Returns the string-value of a node,
-- the value of a namespace node is not supported

stringValue                     :: NavXmlTree -> XPathValue
stringValue                     = XPVString . xpTextOf . self

{-
      textFilter
        = getXCmt `orElse`
--        getXNamespace `orElse`
          multi isXText

--        = (isXTag `guards` multi isXText) `orElse`
--          (isXPi `guards` multi isXText) `orElse`
--          (isXAttr `guards` multi isXText) `orElse`
--          (isXText `guards` multi isXText) `orElse`
--          getXCmt
-}


-- -----------------------------------------------------------------------------
-- |
-- string string(object?): converts an object to a string

xstring                                 :: XFct
xstring _ _ [XPVNode ns]
    | nullNodeSet ns                    = XPVString ""
    | otherwise                         = stringValue . headNodeSet $ ns
xstring (_, _, cn) _ []                 = stringValue cn

xstring _ _ [XPVNumber (Float a)]
    | a == (fromInteger $ round a)      = XPVString (show ((round a)::Integer))
    | otherwise                         = XPVString (show a)
xstring _ _ [XPVNumber s]               = XPVString (show s)

xstring _ _ [XPVBool True]              = XPVString "true"
xstring _ _ [XPVBool False]             = XPVString "false"

xstring _ _ [XPVString s]               = XPVString s
xstring _ _ [XPVError e]                = XPVError e
xstring _ _ _                           = XPVError "Call to xstring with a wrong argument"

-- -----------------------------------------------------------------------------
-- |
-- string concat(string, string, string*): returns the concatenation of its arguments

xconcat                                 :: XFct
xconcat c env args                      = XPVString (foldr (\ (XPVString s) -> (s ++)) "" (toXValue xstring c env args))

-- -----------------------------------------------------------------------------
-- |
-- boolean starts-with(string, string):
-- returns true if the first argument string starts
-- with the second argument string, and otherwise returns false

xstartsWith                             :: XFct
xstartsWith c env args                  = XPVBool $
                                          (\ ((XPVString a):[XPVString b]) -> strStartsWith a b) $
                                          toXValue xstring c env args

-- -----------------------------------------------------------------------------
-- |
-- boolean contains(string, string):
-- returns true if the first argument string contains the second argument string,
-- and otherwise returns false

xcontains                               :: XFct
xcontains c env args                    = XPVBool $
                                          (\ ((XPVString s):[XPVString sub]) -> getFirstPos s sub /= -1) $
                                          toXValue xstring c env args


-- -----------------------------------------------------------------------------
-- |
-- string substring-before(string, string):
-- returns the substring of the first argument string that precedes the first occurrence of
-- the second argument string
-- in the first argument string, or the empty string if the first argument string does not
-- contain the second argument string

xsubstringBefore                                        :: XFct
xsubstringBefore c env args                             = xsubstringBefore' c env (toXValue xstring c env args)

xsubstringBefore'                                       :: XFct
xsubstringBefore' _ _ ((XPVString _):[XPVString []])    = XPVString ""
xsubstringBefore' _ _ ((XPVString s):[XPVString sub])   = XPVString (take (getFirstPos s sub) s)
xsubstringBefore' _ _ _                                 = XPVError  "Call to xsubstringBefore' with a wrong argument"

-- -----------------------------------------------------------------------------
-- |
-- string substring-after(string, string):
-- returns the substring of the first argument string that follows the first occurrence of
-- the second argument string
-- in the first argument string, or the empty string if the first argument string does not
-- contain the second argument string

xsubstringAfter                                         :: XFct
xsubstringAfter c env args                              = xsubstringAfter' c env (toXValue xstring c env args)

xsubstringAfter'                                        :: XFct
xsubstringAfter' _ _ ((XPVString s):[XPVString []])     = XPVString s
xsubstringAfter' _ _ ((XPVString s):[XPVString sub])    = if getFirstPos s sub == -1
                                                          then (XPVString "")
                                                          else XPVString (drop ((getFirstPos s sub)+length sub) s)
xsubstringAfter' _ _ _                                  = XPVError "Call to xsubstringAfter' with a wrong argument"


-- -----------------------------------------------------------------------------
-- |
-- string substring(string, number, number?):
-- returns the substring of the first argument starting at the position specified
-- in the second argument
-- with length specified in the third argument. If the third argument is not specified,
-- it returns the substring
-- starting at the position specified in the second argument and continuing to the end of the string.

xsubstring                              :: XFct
xsubstring c env (x:xs)                 = xsubstring' c env ((toXValue xstring c env [x])++(toXValue xnumber c env xs))
xsubstring _ _ _                        = XPVError "Call to xsubstring with a wrong argument"

xsubstring'                             :: XFct
xsubstring' c env ((XPVString s):start:[])
                                        = case xround c env [start] of
                                          XPVNumber NaN       -> XPVString ""
                                          XPVNumber PosInf    -> XPVString ""
                                          XPVNumber (Float f) -> XPVString (drop ((round f)-1) s)
                                          XPVNumber _         -> XPVString s
                                          _                   -> XPVError "Call to xsubstring' with a wrong argument"

xsubstring' c env ((XPVString s):start:[end])
                                        = case xPathAdd Plus (xround c env [start]) (xround c env [end]) of
                                          XPVNumber (Float f) -> xsubstring' c env ( (XPVString (take ((round f) -1) s)):[start])
                                          XPVNumber PosInf    -> xsubstring' c env ( (XPVString s):[start])
                                          XPVNumber _         -> XPVString ""
                                          _                   -> XPVError "Call to xsubstring' with a wrong argument"
xsubstring' _ _ _                       = XPVError "Call to xsubstring' with a wrong argument"


-- -----------------------------------------------------------------------------
-- |
-- number string-length(string?):
-- returns the number of characters in the string. If the argument is omitted,
-- it defaults to the context node
-- converted to a string, in other words the string-value of the context node.

xstringLength                           :: XFct
xstringLength c@(_, _, cn) env []       = XPVNumber (Float (fromIntegral $ length s))
                                          where
                                          XPVString s = xstring c env [XPVNode $ singletonNodeSet cn]

xstringLength c env args                = XPVNumber $
                                          (\[XPVString s] -> int2XPNumber $ length s) $
                                          toXValue xstring c env args


-- -----------------------------------------------------------------------------
-- |
-- string normalize-space(string?):
-- returns the argument string with whitespace normalized by stripping leading
-- and trailing whitespace and replacing sequences
-- of whitespace characters by a single space. If the argument is omitted,
-- it defaults to the context node converted to a string,
-- in other words the string-value of the context node.
-- The string is parsed by a function parseStr from XPathParser module. <-- No longer! Tim Walkenhorst

xnormalizeSpace                         :: XFct
xnormalizeSpace c@(_, _, cn) env []     = (\ (XPVString s) -> XPVString $ normStr s) $
                                          xstring c env [XPVNode $ singletonNodeSet cn]
xnormalizeSpace c env args              = (\ [XPVString s] -> XPVString $ normStr s) $
                                          toXValue xstring c env args

-- Tim Walkenhorst normStr replaces the use of parseStr...
normStr                                 :: String -> String
normStr                                 = unwords . words

-- -----------------------------------------------------------------------------
-- |
-- string translate(string, string, string):
-- returns the first argument string with occurrences of characters in the second argument string replaced by the character at
-- the corresponding position in the third argument string

xtranslate                              :: XFct
xtranslate c env args                   = xtranslate' c env (toXValue xstring c env args)

xtranslate'                             :: XFct
xtranslate' _ _ ((XPVString a):(XPVString b):[XPVString c])
                                        = XPVString (replace a b c)
xtranslate' _ _ _                       = XPVError "Call to xtranslate' with a wrong argument"

replace                                 :: String -> String -> String -> String
replace str [] _                        = str

-- remove all characters, if there is no corresponding character in the third argument
replace str (x:xs) []                   = replace [ s | s <- str, x /= s] xs []

replace str (x:xs) (y:ys)               = replace (rep x y str) xs ys
                                          where -- replace all characters in the first argument
                                          rep :: Char -> Char -> String -> String
                                          rep a b = foldr (\c -> if c == a then (b:) else (c:)) ""

-- ------------------------------------------------------------
-- boolean functions

-- |
-- boolean boolean(object): converts its argument to a boolean value

xboolean                                :: XFct
xboolean _ _ [XPVNumber a]              = XPVBool (a/= NaN && a/= Neg0 && a/= Pos0)
xboolean _ _ [XPVString s]              = XPVBool (length s /= 0)
xboolean _ _ [XPVBool b]                = XPVBool b
xboolean _ _ [XPVNode ns]               = XPVBool (not . nullNodeSet $ ns)
xboolean _ _ [XPVError e]               = XPVError e
xboolean _ _ _                          = XPVError "Call to xboolean with a wrong argument"


-- -----------------------------------------------------------------------------
-- |
-- boolean not(boolean): returns true if its argument is false, and false otherwise
xnot                                    :: XFct
xnot c env args                         = XPVBool ( (\ (XPVBool b) -> not b) (xboolean c env args) )

-- -----------------------------------------------------------------------------
-- |
-- boolean true(): returns true
xtrue                                   :: XFct
xtrue _ _ _                             = XPVBool True

-- -----------------------------------------------------------------------------
-- |
-- boolean false(): returns false
xfalse                                  :: XFct
xfalse _ _ _                            = XPVBool False

-- -----------------------------------------------------------------------------
-- |
-- boolean lang(string):
-- returns true or false depending on whether the language of the context node as specified by xml:lang attributes
-- is the same as or is a sublanguage of the language specified by the argument string

-- -----------------------------------------------------------------------------
--
-- function needs namespaces which are not supported by the toolbox (???)

xlang                                   :: XFct
xlang _ _ _                             = XPVError "namespaces are not supported"

-- xlang c env args
--    = (\ (_, _, cn) [XPVString s] -> ...) c (toXValue xstring c env args)

-- ------------------------------------------------------------
-- number functions

-- |
-- number number(object?): converts its argument to a number
xnumber                                 :: XFct
xnumber c@(_, _, cn) env []             = (\ (XPVString s) -> parseNumber s) (xstring c env [XPVNode $ singletonNodeSet cn])
xnumber c env [n@(XPVNode _)]           = (\ (XPVString s) -> parseNumber s) (xstring c env [n])

xnumber _ _ [XPVBool b]
    | b                                 = XPVNumber (Float 1)
    | otherwise                         = XPVNumber Pos0

xnumber _ _ [XPVString s]               = parseNumber s
xnumber _ _ [XPVNumber a]               = XPVNumber a
xnumber _ _ [XPVError e]                = XPVError e
xnumber _ _ _                           = XPVError "Call to xnumber with a wrong argument"

-- -----------------------------------------------------------------------------
-- |
-- number sum(node-set):
-- returns the sum, for each node in the argument node-set, of the result of
-- converting the string-values of the node to a number

xsum                                    :: XFct
xsum c env [XPVNode ns]
    | nullNodeSet ns                    = XPVNumber NaN
    | otherwise                         = foldr1 (\ a b -> (xPathAdd Plus a b)) (getValues ns)
      where
      getValues                         :: NodeSet -> [XPathValue]
      getValues                         = foldr (\ n -> ([xnumber c env $ [stringValue n] ] ++) ) [] . fromNodeSet

xsum _ _ _                              = XPVError "The value of the function sum is not a nodeset"

-- -----------------------------------------------------------------------------
-- |
-- number floor(number): returns the largest (closest to positive infinity) number that is not greater
-- than the argument and that is an integer

xfloor                                  :: XFct
xfloor c env args                       = xfloor' (toXValue xnumber c env args)
    where
    xfloor' [XPVNumber (Float f)]
        | f > 0 && f < 1                = XPVNumber Pos0
        | otherwise                     = XPVNumber (Float (fromInteger $ floor f))
    xfloor' [XPVNumber a]               = XPVNumber a
    xfloor' _                           = XPVError "Call to xfloor' without a number"

-- -----------------------------------------------------------------------------
-- |
-- number ceiling(number): returns the smallest (closest to negative infinity) number that is not less
-- than the argument and that is an integer

xceiling                                :: XFct
xceiling c env args                     = xceiling' (toXValue xnumber c env args)
    where
    xceiling' [XPVNumber (Float f)]
        | f < 0 && f > -1               = XPVNumber Pos0
        | otherwise                     = XPVNumber (Float (fromInteger $ ceiling f))
    xceiling' [XPVNumber a]             = XPVNumber a
    xceiling' _                         = XPVError "Call to xceiling' without a number"

-- -----------------------------------------------------------------------------
-- |
-- number round(number):
-- returns the number that is closest to the argument and that is an integer.
-- If there are two such numbers, then the one that is closest to positive infinity is returned.

xround                                  :: XFct
xround c env args                       = xround' c env (toXValue xnumber c env args)

xround'                                 :: XFct
xround' _ _ [XPVNumber (Float f)]
    | f < 0 && f >= -0.5                = XPVNumber Neg0
    | f >= 0 && f < 0.5                 = XPVNumber Pos0
    | otherwise                         = XPVNumber (Float (fromInteger $ xPathRound f))
    where
    xPathRound a                        = if a - (fromInteger $ floor a) < 0.5
                                          then floor a
                                          else floor (a+1)

xround' _ _ [XPVNumber a]               = XPVNumber a
xround' _ _ _                           = XPVError "Call to xround' without a number"

-- -----------------------------------------------------------------------------
-- |
-- node-set key(string, object):
-- does for keys what the id function does for IDs
-- The first argument specifies the name of the key.
-- When the second argument is of type node-set, then the result is the
-- union of the result of applying the key function to the string value
-- of each of the nodes in the argument node-set.
-- When the second argument is of any other type, the argument is
-- converted to a string
xkey                                    :: XFct
xkey _ env ((XPVString s) : [XPVNode ns])
                                        = isInKey (getKeyTab env) s (strValues . fromNodeSet $ ns)
    where
    strValues                           = map ((\ (XPVString str) -> str) . stringValue)

xkey c env ((XPVString s) : arg)        -- = isInKey (getKeyTab env) s  ( (\(XPVString s) -> words s) (xstring c env arg))
                                        = isInKey (getKeyTab env) s [str]
                                          where
                                          XPVString str = xstring c env arg

xkey _ _ _                              = XPVError "Call to xkey with a wrong argument"


isInKey                                 :: KeyTab -> String -> [String] -> XPathValue
isInKey kt kn kv                        = XPVNode . toNodeSet $ ts
    where
    (_, _, ts)                          = unzip3 $ concat $ map (isKeyVal (isKeyName kt kn)) kv

isKeyName                               :: KeyTab -> String -> KeyTab
isKeyName kt kn                         = filter (isOfKeyName kn) kt

isKeyVal                                :: KeyTab -> String -> KeyTab
isKeyVal kt kv                          = filter (isOfKeyValue kv) kt

isOfKeyName                             :: String -> (QName, String, NavXmlTree) -> Bool
isOfKeyName kn (qn, _, _)               = localPart qn == kn


isOfKeyValue                            :: String -> (QName, String, NavXmlTree) -> Bool
isOfKeyValue kv (_, v, _)               = v == kv


-- -----------------------------------------------------------------------------
-- |
-- string format-number(number, string, string?):
-- converts its first argument to a string using the format pattern string
-- specified by the second argument and the decimal-format named by the
-- third argument, or the default decimal-format, if there is no third argument

xformatNumber                           :: XFct
xformatNumber c env (x:xs)              = xsubstring' c env (toXValue xstring c env [x] ++ toXValue xnumber c env xs)
xformatNumber _ _ _                     = XPVError "Call to xformatNumber with a wrong argument"


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

-- Poor man's document(...) function. Opens exactly one document.
-- Does not support "fragment identifiers". "Base-URI" is always current directory.
-- Should still be good enough for home use.

xdocument                               :: XFct
xdocument c e val                       = XPVNode . toNodeSet . (\ (XPVString s) -> xdocument' s) . xstring c e $ val

xdocument'                              :: String -> [NavXmlTree]
xdocument' uri                          = map ntree $
                                          unsafePerformIO $
                                          runX ( readDocument [withValidate no] uri
                                                 >>>
                                                 addAttr "rootId" ("doc " ++ uri)
                                               )

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

-- generate-id, should be fully compliant with XSLT specification.

xgenerateId                             :: XFct
xgenerateId _            _ [XPVNode ns]
    | not (nullNodeSet ns)              = xgenerateId' . headNodeSet $ ns

xgenerateId (_, _, node) _ []           = xgenerateId' node
xgenerateId _            _ _            = error "illegal arguments in xgenerateId"

xgenerateId'                            :: NavXmlTree -> XPathValue
xgenerateId'                            = XPVString . ("id_"++) . str2XmlId . show . nodeID . Just

str2XmlId                               :: String -> String
str2XmlId                               = concatMap convert
    where
    convert c                           = if isAscii c && (isUpper c || isLower c || isDigit c)
                                          then [c]
                                          else "_" ++ (show $ ord c) ++ "_"

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

xpNamePart :: LA XmlTree String -> XmlTree -> String
xpNamePart getNp
    = concat
      .
      runLA ( ifA isRoot
              (constA "")
              getNp
            )

xpLocalPartOf   :: XmlTree -> String
xpLocalPartOf   = xpNamePart getLocalPart

xpNamespaceOf   :: XmlTree -> String
xpNamespaceOf   = xpNamePart getNamespaceUri

xpNameOf        :: XmlTree -> String
xpNameOf        = xpNamePart getName

getValue        :: String -> XmlTree -> String
getValue n      = concat . runLA (getAttrValue n)

xpTextOf        :: XmlTree -> String
xpTextOf        = concat . runLA (xshow ((getCmt >>> mkText) <+> deep isText))

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