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 Text.XML.HXT.Arrow.ReadDocument (readDocument)
import Text.XML.HXT.Arrow.XmlIOStateArrow (runX)
import Text.XML.HXT.DOM.XmlTree
hiding (mkNode)
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe
( fromJust )
import Data.Char
import Data.List
( sortBy )
int2XPNumber :: Int -> XPNumber
int2XPNumber 0 = Pos0
int2XPNumber i = Float $ fromIntegral i
type XFct = (Context -> Env -> [XPathValue] -> XPathValue)
type FctTable = [(FctName, FctTableElem)]
type FctTableElem = (XFct, CheckArgCount)
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
fctTable :: FctTable
fctTable = [
("last", (xlast, zero)),
("position",(xposition, zero)),
("count",(xcount, one)),
("id", (xid, one)),
("local-name", (xlocalName, zeroOrOne)),
("namespace-uri", (xnamespaceUri, zeroOrOne)),
("name", (xname, zeroOrOne)),
("string", (xstring, zeroOrOne)),
("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)),
("not", (xnot, one)),
("true", (xtrue, zero)),
("false",(xfalse, zero)),
("lang", (xlang, one)),
("number",(xnumber, zeroOrOne)),
("sum",(xsum, one)),
("floor",(xfloor, one)),
("ceiling",(xceiling, one)),
("round",(xround, one)),
("key",(xkey, two)),
("format-number",(xformatNumber, twoOrThree)),
("document", (xdocument, one)),
("generate-id", (xgenerateId, zeroOrOne))
]
getKeyTab :: Env -> KeyTab
getKeyTab (_, keyTab) = keyTab
getVarTab :: Env -> VarTab
getVarTab (varTab, _) = varTab
getConvFct :: XPathValue -> Maybe XFct
getConvFct (XPVNumber _) = Just xnumber
getConvFct (XPVString _) = Just xstring
getConvFct (XPVBool _) = Just xboolean
getConvFct _ = Nothing
createDocumentOrder :: XPathFilter
createDocumentOrder (XPVNode n) = XPVNode (sortBy documentOrder n)
where
documentOrder :: NavXmlTree -> NavXmlTree -> Ordering
documentOrder a b = compare (documentPos a) (documentPos b)
createDocumentOrder e@(XPVError _) = e
createDocumentOrder _ = XPVError "Call to createDocumentOrder without a nodeset"
createDocumentOrderReverse :: XPathFilter
createDocumentOrderReverse (XPVNode n) = XPVNode (sortBy documentOrderReverse n)
where
documentOrderReverse :: NavXmlTree -> NavXmlTree -> Ordering
documentOrderReverse a b = compare (documentPos b) (documentPos a)
createDocumentOrderReverse e@(XPVError _) = e
createDocumentOrderReverse _ = XPVError "Call to createDocumentOrderReverse without a nodeset"
remDups :: XPathFilter
remDups e@(XPVError _) = e
remDups (XPVNode []) = XPVNode []
remDups (XPVNode (x:xs))
| isNotInNodeList x xs = XPVNode (x : y)
| otherwise = remDups (XPVNode xs)
where
(XPVNode y) = remDups (XPVNode xs)
remDups _ = XPVError "Call to remDups without a nodeset"
isNotInNodeList :: NavXmlTree -> [NavXmlTree] -> Bool
isNotInNodeList n xs' = nodeID (Just n) `notElem` map (nodeID . Just) xs'
data IdPathStep = IdRoot String | IdPos Int | IdAttr QName deriving (Show, Eq, Ord)
nodeID :: Maybe (NavXmlTree) -> [IdPathStep]
nodeID Nothing = []
nodeID (Just t@(NT (NTree (XAttr qn) _) _ _ _)) = IdAttr qn : nodeID (upNT t)
nodeID (Just t@(NT node _ prev _))
| isRootNode $ getNode node = return $ IdRoot (getText $ getValue "rootId" node)
| otherwise = IdPos (length prev) : nodeID (upNT t)
where getText ((NTree (XText t') _):_) = t'
getText _ = ""
documentPos :: NavXmlTree -> [IdPathStep]
documentPos tree = reverse $ nodeID (Just tree)
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
toXValue :: XFct -> Context -> Env -> [XPathValue] -> [XPathValue]
toXValue fct c env args = [fct c env [x] | x <- args]
xlast :: XFct
xlast (_, len , _) _ _ = XPVNumber $ int2XPNumber len
xposition :: XFct
xposition (pos, _ , _) _ _ = XPVNumber $ int2XPNumber pos
xcount :: XFct
xcount _ _ [XPVNode ns] = XPVNumber $ int2XPNumber $ length ns
xcount _ _ _ = XPVError "Call to function count with wrong arguments"
xid :: XFct
xid (_, _, cn) env [XPVNode ns]
= isInId (getIds env) (strValues ns) [cn]
where
strValues = map ((\ (XPVString str) -> str) . stringValue)
xid c@(_, _, cn) env arg
= isInId (getIds env) ( (\(XPVString s) -> words s) (xstring c env arg)) [cn]
getIds :: Env -> [String]
getIds env
= words $ (\ (XPVString str) -> str) . fromJust $ lookup ("", "idAttr") $ getVarTab env
isInId :: [String] -> [String] -> NavXmlTrees -> XPathValue
isInId ids str ns
= remDups (XPVNode (concat $ map (filterNS ids str . descendantOrSelfAxis) ns))
filterNS :: [String] -> [String] -> NavXmlTrees -> NavXmlTrees
filterNS ids str ns
= [ n | n@(NT a@(NTree _ _) _ _ _) <- ns, or $ map (idInIdList a str) ids]
where
idInIdList :: XmlTree -> [String] -> String -> Bool
idInIdList al str' b = (xshow $ getValue b al) `elem` str'
xlocalName :: XFct
xlocalName (_, _, cn) _ [] = XPVString (xpLocalPartOf $ subtreeNT cn)
xlocalName _ _ [XPVNode []] = XPVString ""
xlocalName _ _ [XPVNode ns] = XPVString (xpLocalPartOf $ subtreeNT $ head $ ns)
xlocalName _ _ _ = XPVError "Call to function local-name with wrong arguments"
xpLocalPartOf :: XmlTree -> String
xpLocalPartOf n = if isRootNode (getNode n)
then ""
else localPartOf n
xnamespaceUri :: XFct
xnamespaceUri (_, _, cn) _ [] = XPVString (namespaceOf $ subtreeNT cn)
xnamespaceUri _ _ [XPVNode []] = XPVString ""
xnamespaceUri _ _ [XPVNode ns] = XPVString (namespaceOf $ subtreeNT $ head $ ns)
xnamespaceUri _ _ _ = XPVError "Call to function namespace-uri with wrong arguments"
xname :: XFct
xname (_, _, cn) _ [] = XPVString (xpNameOf $ subtreeNT cn)
xname _ _ [XPVNode []] = XPVString ""
xname _ _ [XPVNode ns] = XPVString (xpNameOf $ subtreeNT $ head $ ns)
xname _ _ _ = XPVError "Call to function name with wrong arguments"
xpNameOf :: XmlTree -> String
xpNameOf n = if isRootNode (getNode n)
then ""
else nameOf n
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
stringValue :: NavXmlTree -> XPathValue
stringValue (NT a _ _ _)
= XPVString $ xshow . textFilter $ a
where
textFilter
= getXCmt `orElse`
multi isXText
xstring :: XFct
xstring _ _ [XPVNode []] = XPVString ""
xstring _ _ [XPVNode (x:_)] = stringValue x
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"
xconcat :: XFct
xconcat c env args
= XPVString (foldr (\ (XPVString s) -> (s ++)) "" (toXValue xstring c env args))
xstartsWith :: XFct
xstartsWith c env args
= XPVBool ( (\ ((XPVString a):[XPVString b]) -> strStartsWith a b) (toXValue xstring c env args))
xcontains :: XFct
xcontains c env args
= XPVBool ( (\ ((XPVString s):[XPVString sub]) -> getFirstPos s sub /= 1) (toXValue xstring c env args))
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"
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"
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"
xstringLength :: XFct
xstringLength c@(_, _, cn) env []
= XPVNumber (Float (fromIntegral $ length s))
where (XPVString s) = xstring c env [XPVNode [cn]]
xstringLength c env args
= XPVNumber $ (\[XPVString s] -> int2XPNumber $ length s) (toXValue xstring c env args)
xnormalizeSpace :: XFct
xnormalizeSpace c@(_, _, cn) env []
= (\(XPVString s) -> XPVString $ normStr s) (xstring c env [XPVNode [cn]])
xnormalizeSpace c env args
= (\ [XPVString s] -> XPVString $ normStr s) (toXValue xstring c env args)
normStr :: String -> String
normStr = unwords . words
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
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
rep :: Char -> Char -> String -> String
rep a b = foldr (\c -> if c == a then (b:) else (c:)) ""
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 (length ns > 0)
xboolean _ _ [XPVError e] = XPVError e
xboolean _ _ _ = XPVError "Call to xboolean with a wrong argument"
xnot :: XFct
xnot c env args
= XPVBool ( (\ (XPVBool b) -> not b) (xboolean c env args) )
xtrue :: XFct
xtrue _ _ _ = XPVBool True
xfalse :: XFct
xfalse _ _ _ = XPVBool False
xlang :: XFct
xlang _ _ _
= XPVError "namespaces are not supported"
xnumber :: XFct
xnumber c@(_, _, cn) env []
= (\(XPVString s) -> parseNumber s) (xstring c env [XPVNode [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"
xsum :: XFct
xsum _ _ [XPVNode []] = XPVNumber NaN
xsum c env [XPVNode ns]
= foldr1 (\ a b -> (xPathAdd Plus a b)) (getValues ns)
where
getValues :: NodeSet -> [XPathValue]
getValues = foldr (\ n -> ([xnumber c env $ [stringValue n] ] ++) ) []
xsum _ _ _
= XPVError "The value of the function sum is not a nodeset"
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"
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"
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"
xkey :: XFct
xkey _ env ((XPVString s) : [XPVNode ns])
= isInKey (getKeyTab env) s (strValues ns)
where
strValues = map ((\ (XPVString str) -> str) . stringValue)
xkey c env ((XPVString s) : 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 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
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"
xdocument :: XFct
xdocument c e val = XPVNode $ (\(XPVString s) -> xdocument' s) $ xstring c e val
xdocument' :: String -> [NavXmlTree]
xdocument' uri = map ntree $ concatMap (addAttr "rootId" ("doc " ++ uri)) $ unsafePerformIO $ runX $ readDocument [(a_validate, v_0)] uri
xgenerateId :: XFct
xgenerateId _ _ [XPVNode (node:_)] = xgenerateId' node
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) ++ "_"