module Text.XML.HXT.XPath.XPathFct
( XFct
, evalFct
, toXValue
, xnumber
, xboolean
, xstring
, getConvFct
, stringValue
, isNotInNodeList
, 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
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
isNotInNodeList :: NavXmlTree -> [NavXmlTree] -> Bool
isNotInNodeList n xs' = nodeID' n `notElem` map nodeID' xs'
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")
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 . cardNodeSet $ 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) . fromNodeSet
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 = 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'
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"
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"
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"
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 = XPVString . xpTextOf . self
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"
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 $ singletonNodeSet 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 $ singletonNodeSet 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 (not . nullNodeSet $ ns)
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 $ 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"
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"
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 . fromNodeSet $ 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 . 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
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 . 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)
)
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))