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 )
import Text.XML.HXT.DOM.Interface
import qualified Text.XML.HXT.DOM.XmlNode as XN
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 )
getXPath :: String -> XmlTree -> XmlTrees
getXPath = getXPathWithNsEnv []
getXPath' :: Expr -> XmlTree -> XmlTrees
getXPath' e = runLA $
canonicalizeForXPath
>>>
arrL (getXPathValues' xPValue2XmlTrees e)
getXPathWithNsEnv :: Attributes -> String -> XmlTree -> XmlTrees
getXPathWithNsEnv env s = runLA ( canonicalizeForXPath
>>>
arrL (getXPathValues xPValue2XmlTrees xPathErr env s)
)
getXPathSubTrees :: String -> XmlTree -> XmlTrees
getXPathSubTrees = getXPathSubTreesWithNsEnv []
getXPathSubTrees' :: Expr -> XmlTree -> XmlTrees
getXPathSubTrees' = getXPathValues' xPValue2XmlTrees
getXPathSubTreesWithNsEnv :: Attributes -> String -> XmlTree -> XmlTrees
getXPathSubTreesWithNsEnv nsEnv xpStr = getXPathValues xPValue2XmlTrees xPathErr nsEnv xpStr
getXPathNodeSet' :: String -> XmlTree -> XmlNodeSet
getXPathNodeSet' = getXPathNodeSetWithNsEnv' []
getXPathNodeSet'' :: Expr -> XmlTree -> XmlNodeSet
getXPathNodeSet'' = getXPathValues' xPValue2XmlNodeSet
getXPathNodeSetWithNsEnv' :: Attributes -> String -> XmlTree -> XmlNodeSet
getXPathNodeSetWithNsEnv' nsEnv xpStr = getXPathValues xPValue2XmlNodeSet (const emptyXmlNodeSet) nsEnv xpStr
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 ]
getXPathValues' :: (XPathValue -> a) -> Expr -> XmlTree -> a
getXPathValues' cvRes xpExpr t = cvRes xpRes
where
t' = addRoot' t
idAttr = ( ("", "idAttr")
, 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]
parseXPathExpr :: String -> Either String Expr
parseXPathExpr = parseXPathExprWithNsEnv []
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
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"
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"
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"
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
relEqEv' env cont op a@(XPVNode _)
b@(XPVNode _) = relEqTwoNodes env cont op a b
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
relEqEv' env cont Eq a b = eqEv env cont (==) a b
relEqEv' env cont NEq a b = eqEv env cont (/=) a b
relEqEv' env cont op a b = XPVBool ((fromJust $ getOpFct op) (toXNumber a) (toXNumber b))
where
toXNumber x = xnumber cont env [x]
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"
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
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
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
getAxisNodes :: AxisSpec -> NodeSet -> [NodeListRes]
getAxisNodes as = map (Right . (fromJust $ lookup as axisFctL)) . fromNodeSet
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)
]
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
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
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]
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
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
where
namespaceAware = not . null . namespaceUri $ xpName
prefixMatch = not . null . namePrefix $ xpName
wildcardTest _ _ = False
typeTest :: XPathNode -> NodeList -> NodeList
typeTest XPNode = id
typeTest XPCommentNode = filterNodes' XN.isCmt
typeTest XPPINode = filterNodes' XN.isPi
typeTest XPTextNode = filterNodes' XN.isText
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"
getVariable :: Env -> VarName -> XPathFilter
getVariable env name _ = fromMaybe (XPVError ("Variable: " ++ show name ++ " not found")) $
lookup name (getVarTab env)
fctEval :: Env -> Context -> FctName -> [Expr] -> XPathFilter
fctEval env cont name args = evalFct name env cont . evalExprL env cont args
numEval :: (Op -> XPathValue -> XPathValue -> XPathValue) ->
Op -> [XPathValue] -> XPathValue
numEval f op = foldl1 (f op)
idAttributesToXPathValue :: XmlTrees -> XPathValue
idAttributesToXPathValue ts = XPVString (foldr (\ n -> ( (valueOfDTD a_value n ++ " ") ++)) [] ts)
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)