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.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 (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
new_ns@(XPVNode _) -> evalPredL env predicates new_ns
_ -> 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
getAxisNodes :: AxisSpec -> XPathFilter
getAxisNodes as = withXPVNode "Call to getAxis without a nodeset" evalAxis
where
evalAxis = XPVNode .
withNodeSet (concatMap (fromJust $ lookup as axisFctL))
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 (evalStep env) ns steps
evalStep :: Env -> XPathValue -> XStep -> XPathValue
evalStep _ _ (Step Namespace _ _) = XPVError "namespace-axis not supported"
evalStep _ ns (Step Attribute nt _) = evalAttr nt (getAxisNodes Attribute ns)
evalStep env ns (Step axisSpec nt pr) = evalStep' env pr nt (getAxisNodes axisSpec ns)
evalAttr :: NodeTest -> XPathFilter
evalAttr nt = withXPVNode "Call to evalAttr without a nodeset" $
evalTest
where
evalTest = XPVNode .
withNodeSet (concatMap . 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 -> XPathFilter
evalStep' env pr nt = evalPredL env pr . nodeTest nt
evalPredL :: Env -> [Expr] -> XPathFilter
evalPredL env pr n = withXPVNode "Call to evalPredL without a nodeset" evalPl n
where
evalPl ns = foldl (evalPred env 1 (cardNodeSet ns)) n pr
evalPred :: Env -> Int -> Int -> XPathValue -> Expr -> XPathValue
evalPred env pos len nv@(XPVNode ns) ex
| nullNodeSet ns = nv
| otherwise = case testPredicate env (pos, len, x) ex (XPVNode . singletonNodeSet $ x) of
e@(XPVError _) -> e
XPVBool True -> XPVNode $ insertNodeSet x n
XPVBool False -> nextNode
_ -> XPVError "Value of testPredicate is not a boolean"
where
(xp, x) = head . elemsNodeSet $ ns
xs = deleteNodeSet xp ns
nextNode@(XPVNode n) = evalPred env (pos + 1) len (XPVNode xs) ex
evalPred _ _ _ _ _ = XPVError "Call to evalPred without a nodeset"
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 -> XPathFilter
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
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 -> XPathFilter
typeTest XPNode = id
typeTest XPCommentNode = filterNodes XN.isCmt
typeTest XPPINode = filterNodes XN.isPi
typeTest XPTextNode = filterNodes XN.isText
filterNodes :: (XNode -> Bool) -> XPathFilter
filterNodes fct = withXPVNode "Call to filterNodes without a nodeset" $
(XPVNode . withNodeSet (filter (fct . dataNT)))
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)