module Text.XML.HXT.XPath.XPathParser
( parseNumber
, parseXPath
)
where
import Text.ParserCombinators.Parsec
import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.XPath.XPathKeywords
import Text.XML.HXT.XPath.XPathDataTypes
import Text.XML.HXT.Parser.XmlCharParser ( XParser
, XPState(..)
, withNormNewline
)
import Text.XML.HXT.Parser.XmlTokenParser ( separator
, systemLiteral
, skipS0
, ncName
, qName
)
lookupNs :: NsEnv -> XName -> Maybe XName
lookupNs uris prefix
| null uris = Just nullXName
| isNullXName prefix = maybe (Just nullXName) Just $
lookup prefix uris
| otherwise = lookup prefix uris
enhanceAttrQName :: NsEnv -> QName -> Maybe QName
enhanceAttrQName uris qn
| isNullXName (namePrefix' qn) = Just qn
| otherwise = enhanceQName uris qn
enhanceQName :: NsEnv -> QName -> Maybe QName
enhanceQName uris qn = do
nsu <- lookupNs uris (namePrefix' qn)
return $ setNamespaceUri' nsu qn
enhanceQN :: AxisSpec -> NsEnv -> QName -> Maybe QName
enhanceQN Attribute = enhanceAttrQName
enhanceQN _ = enhanceQName
type XPathParser a = XParser NsEnv a
parseNumber :: String -> XPathValue
parseNumber s
= case (runParser parseNumber' (withNormNewline []) "" s) of
Left _ -> XPVNumber NaN
Right x -> if (read x :: Float) == 0
then (XPVNumber Pos0)
else XPVNumber (Float (read x))
parseNumber' :: XPathParser String
parseNumber'
= do
skipS0
m <- option "" (string "-")
n <- number
skipS0
eof
return (m ++ n)
parseXPath :: XPathParser Expr
parseXPath
= do
skipS0
xPathExpr <- expr
skipS0
eof
return xPathExpr
lpar, rpar, lbra, rbra, slash, dslash :: XPathParser ()
lpar = tokenParser (symbol "(")
rpar = tokenParser (symbol ")")
lbra = tokenParser (symbol "[")
rbra = tokenParser (symbol "]")
slash = tokenParser (symbol "/")
dslash = tokenParser (symbol "//")
tokenParser :: XPathParser String -> XPathParser ()
tokenParser p
= try ( do
skipS0
_ <- p
skipS0
)
symbolParser :: (String, a) -> XPathParser a
symbolParser (s,a)
= do
tokenParser (symbol s)
return a
symbol :: String -> XPathParser String
symbol s = try (string s)
orOp, andOp, eqOp, relOp, addOp, multiOp, unionOp :: XPathParser Op
orOp = symbolParser ("or", Or)
andOp = symbolParser ("and", And)
eqOp
= symbolParser ("=", Eq)
<|>
symbolParser ("!=", NEq)
relOp
= choice [ symbolParser ("<=", LessEq)
, symbolParser (">=", GreaterEq)
, symbolParser ("<", Less)
, symbolParser (">", Greater)
]
addOp
= symbolParser ("+", Plus)
<|>
symbolParser ("-", Minus)
multiOp
= choice [ symbolParser ("*", Mult)
, symbolParser ("mod", Mod)
, symbolParser ("div", Div)
]
unionOp = symbolParser ("|", Union)
mkExprNode :: Expr -> [(Op, Expr)] -> Expr
mkExprNode e1 [] = e1
mkExprNode e1 l@((op, _): _) =
if null rest
then GenExpr op (e1:(map snd l))
else GenExpr op $ (e1:(map snd $ init same)) ++ [mkExprNode (snd $ last same) rest]
where
(same, rest) = span ((==op) . fst) l
exprRest :: XPathParser Op -> XPathParser Expr -> XPathParser (Op, Expr)
exprRest parserOp parserExpr
= do
op <- parserOp
e2 <- parserExpr
return (op, e2)
descOrSelfStep :: XStep
descOrSelfStep = (Step DescendantOrSelf (TypeTest XPNode) [])
locPath :: XPathParser LocationPath
locPath
= absLocPath
<|>
relLocPath'
absLocPath :: XPathParser LocationPath
absLocPath
= do
dslash
s <- relLocPath
return (LocPath Abs ([descOrSelfStep] ++ s))
<|>
do
slash
s <- option [] relLocPath
return (LocPath Abs s)
<?> "absLocPath"
relLocPath' :: XPathParser LocationPath
relLocPath'
= do
rel <- relLocPath
return (LocPath Rel rel)
relLocPath :: XPathParser [XStep]
relLocPath
= do
s1 <- step
s2 <- many (step')
return ([s1] ++ (concat s2))
<?> "relLocPath"
step' :: XPathParser [XStep]
step'
= do
dslash
s <- step
return [descOrSelfStep,s]
<|>
do
slash
s <- step
return [s]
<?> "step'"
step :: XPathParser XStep
step
= abbrStep
<|>
do
as <- axisSpecifier'
nt <- nodeTest as
pr <- many predicate
return (Step as nt pr)
<?> "step"
axisSpecifier' :: XPathParser AxisSpec
axisSpecifier'
= do
tokenParser (symbol "@")
return Attribute
<|>
do
as <- option Child ( try ( do
a <- axisSpecifier
tokenParser (symbol "::")
return a
)
)
return as
<?> "axisSpecifier'"
axisSpecifier :: XPathParser AxisSpec
axisSpecifier
= choice [ symbolParser (a_ancestor_or_self, AncestorOrSelf)
, symbolParser (a_ancestor, Ancestor)
, symbolParser (a_attribute, Attribute)
, symbolParser (a_child, Child)
, symbolParser (a_descendant_or_self, DescendantOrSelf)
, symbolParser (a_descendant, Descendant)
, symbolParser (a_following_sibling, FollowingSibling)
, symbolParser (a_following, Following)
, symbolParser (a_namespace, Namespace)
, symbolParser (a_parent, Parent)
, symbolParser (a_preceding_sibling, PrecedingSibling)
, symbolParser (a_preceding, Preceding)
, symbolParser (a_self, Self)
]
<?> "axisSpecifier"
nodeTest :: AxisSpec -> XPathParser NodeTest
nodeTest as
= do
nt <- try nodeType'
return (TypeTest nt)
<|>
do
processInst <- pI
return (PI processInst)
<|>
do
nt <- nameTest as
return (NameTest nt)
<?> "nodeTest"
pI :: XPathParser String
pI
= do
tokenParser (symbol n_processing_instruction)
li <- between lpar rpar literal
return li
<?> "Processing-Instruction"
predicate :: XPathParser Expr
predicate
= do
ex <- between lbra rbra expr
return ex
abbrStep :: XPathParser XStep
abbrStep
= do
tokenParser (symbol "..")
return (Step Parent (TypeTest XPNode) [])
<|>
do
tokenParser (symbol ".")
return (Step Self (TypeTest XPNode) [])
<?> "abbrStep"
expr :: XPathParser Expr
expr = orExpr
primaryExpr :: XPathParser Expr
primaryExpr
= do
vr <- variableReference
return (VarExpr vr)
<|>
do
ex <- between lpar rpar expr
return ex
<|>
do
li <- literal
return (LiteralExpr li)
<|>
do
num <- number
return (NumberExpr (Float $ read num))
<|>
do
fc <- functionCall
return (fc)
<?> "primaryExpr"
functionCall :: XPathParser Expr
functionCall
= do
fn <- functionName
arg <- between lpar rpar ( sepBy expr (separator ',') )
return (FctExpr fn arg)
<?> "functionCall"
unionExpr :: XPathParser Expr
unionExpr
= do
e1 <- pathExpr
eRest <- many (exprRest unionOp pathExpr)
return (mkExprNode e1 eRest)
pathExpr :: XPathParser Expr
pathExpr
= do
fe <- try filterExpr
path <- do
dslash
LocPath t1 t2 <- relLocPath'
return (PathExpr (Just fe) (Just (LocPath t1 ([descOrSelfStep] ++ t2))))
<|>
do
slash
relPath <- relLocPath'
return (PathExpr (Just fe) (Just relPath))
<|>
return fe
return path
<|>
do
lp <- locPath
return (PathExpr Nothing (Just lp))
<?> "pathExpr"
filterExpr :: XPathParser Expr
filterExpr
= do
prim <- primaryExpr
predicates <- many predicate
if length predicates > 0
then return (FilterExpr (prim : predicates))
else return prim
<?> "filterExpr"
orExpr :: XPathParser Expr
orExpr
= do
e1 <- andExpr
eRest <- many (exprRest orOp andExpr)
return (mkExprNode e1 eRest)
<?> "orExpr"
andExpr :: XPathParser Expr
andExpr
= do
e1 <- equalityExpr
eRest <- many (exprRest andOp equalityExpr)
return (mkExprNode e1 eRest)
<?> "andExpr"
equalityExpr :: XPathParser Expr
equalityExpr
= do
e1 <- relationalExpr
eRest <- many (exprRest eqOp relationalExpr)
return (mkExprNode e1 eRest)
<?> "equalityExpr"
relationalExpr :: XPathParser Expr
relationalExpr
= do
e1 <- additiveExpr
eRest <- many (exprRest relOp additiveExpr)
return (mkExprNode e1 eRest)
<?> "relationalExpr"
additiveExpr :: XPathParser Expr
additiveExpr
= do
e1 <- multiplicativeExpr
eRest <- many (exprRest addOp multiplicativeExpr)
return (mkExprNode e1 eRest)
<?> "additiveExpr"
multiplicativeExpr :: XPathParser Expr
multiplicativeExpr
= do
e1 <- unaryExpr
eRest <- many (exprRest multiOp unaryExpr)
return (mkExprNode e1 eRest)
<?> "multiplicativeExpr"
unaryExpr :: XPathParser Expr
unaryExpr
= do
tokenParser (symbol "-")
u <- unaryExpr
return (GenExpr Unary [u])
<|>
do
u <- unionExpr
return u
<?> "unaryExpr"
literal :: XPathParser String
literal = systemLiteral
number :: XPathParser String
number
= do
tokenParser (symbol ".")
d <- many1 digit
return ("0." ++ d)
<|>
do
d <- many1 digit
d1 <- option "" ( do
tokenParser (symbol ".")
d2 <- option "0" (many1 digit)
return ("." ++ d2)
)
return (d ++ d1)
<?> "number"
functionName :: XPathParser String
functionName
= do (p, n) <- try qName
fn <- enhanceName Attribute $ mkPrefixLocalPart p n
if null p
then if n `elem` ["processing-instruction", "comment", "text", "node"]
then fail $ "function name: " ++ n ++ "not allowed"
else return n
else return $ "{" ++ namespaceUri fn ++ "}" ++ n
<?> "functionName"
variableReference :: XPathParser (String, String)
variableReference
= do tokenParser (symbol "$")
(p, n) <- qName
vn <- enhanceName Attribute $ mkPrefixLocalPart p n
return (namespaceUri vn, n)
<?> "variableReference"
nameTest :: AxisSpec -> XPathParser QName
nameTest axs
= do tokenParser (symbol "*")
enhanceName axs $ mkPrefixLocalPart "" "*"
<|>
do pre <- try ( do pre' <- ncName
_ <- symbol ":*"
return pre'
)
enhanceName axs $ mkPrefixLocalPart pre "*"
<|>
do (pre,local) <- qName
enhanceName axs $ mkPrefixLocalPart pre local
<?> "nameTest"
enhanceName :: AxisSpec -> QName -> XPathParser QName
enhanceName axs qn
= do uris <- getState >>= return . xps_userState
case enhanceQN axs uris qn of
Nothing -> fail $ "no namespace uri given for prefix " ++ show (namePrefix qn)
Just qn' -> return qn'
<?> "qualified name with defined namespace uri"
nodeType' :: XPathParser XPathNode
nodeType'
= do
nt <- nodeType
lpar
rpar
return nt
<?> "nodeType'"
nodeType :: XPathParser XPathNode
nodeType
= choice [ symbolParser (n_comment, XPCommentNode)
, symbolParser (n_text, XPTextNode)
, symbolParser (n_processing_instruction, XPPINode)
, symbolParser (n_node, XPNode)
]
<?> "nodeType"