module Text.XML.HXT.XPath.XPathParser
( parseNumber
, parseXPath
)
where
import Data.Maybe
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.XmlTokenParser
( separator
, systemLiteral
, skipS0
, ncName
, qName
)
lookupNs :: NsEnv -> XName -> XName
lookupNs uris prefix
= fromMaybe nullXName $ lookup prefix uris
enhanceAttrQName :: NsEnv -> QName -> QName
enhanceAttrQName uris qn
| isNullXName (namePrefix' qn) = qn
| otherwise = enhanceQName uris qn
enhanceQName :: NsEnv -> QName -> QName
enhanceQName uris qn = setNamespaceUri' ( lookupNs uris (namePrefix' qn) ) qn
enhanceQN :: AxisSpec -> NsEnv -> QName -> QName
enhanceQN Attribute = enhanceAttrQName
enhanceQN _ = enhanceQName
type XParser a = GenParser Char NsEnv a
parseNumber :: String -> XPathValue
parseNumber s
= case (runParser parseNumber' [] "" s) of
Left _ -> XPVNumber NaN
Right x -> if (read x :: Float) == 0
then (XPVNumber Pos0)
else XPVNumber (Float (read x))
parseNumber' :: XParser String
parseNumber'
= do
skipS0
m <- option "" (string "-")
n <- number
skipS0
eof
return (m ++ n)
parseXPath :: XParser Expr
parseXPath
= do
skipS0
xPathExpr <- expr
skipS0
eof
return xPathExpr
lpar, rpar, lbra, rbra, slash, dslash :: XParser ()
lpar = tokenParser (symbol "(")
rpar = tokenParser (symbol ")")
lbra = tokenParser (symbol "[")
rbra = tokenParser (symbol "]")
slash = tokenParser (symbol "/")
dslash = tokenParser (symbol "//")
tokenParser :: XParser String -> XParser ()
tokenParser p
= try ( do
skipS0
_ <- p
skipS0
)
symbolParser :: (String, a) -> XParser a
symbolParser (s,a)
= do
tokenParser (symbol s)
return a
symbol :: String -> XParser String
symbol s = try (string s)
orOp, andOp, eqOp, relOp, addOp, multiOp, unionOp :: XParser 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 :: XParser Op -> XParser Expr -> XParser (Op, Expr)
exprRest parserOp parserExpr
= do
op <- parserOp
e2 <- parserExpr
return (op, e2)
descOrSelfStep :: XStep
descOrSelfStep = (Step DescendantOrSelf (TypeTest XPNode) [])
locPath :: XParser LocationPath
locPath
= absLocPath
<|>
relLocPath'
absLocPath :: XParser LocationPath
absLocPath
= do
dslash
s <- relLocPath
return (LocPath Abs ([descOrSelfStep] ++ s))
<|>
do
slash
s <- option [] relLocPath
return (LocPath Abs s)
<?> "absLocPath"
relLocPath' :: XParser LocationPath
relLocPath'
= do
rel <- relLocPath
return (LocPath Rel rel)
relLocPath :: XParser [XStep]
relLocPath
= do
s1 <- step
s2 <- many (step')
return ([s1] ++ (concat s2))
<?> "relLocPath"
step' :: XParser [XStep]
step'
= do
dslash
s <- step
return [descOrSelfStep,s]
<|>
do
slash
s <- step
return [s]
<?> "step'"
step :: XParser XStep
step
= abbrStep
<|>
do
as <- axisSpecifier'
nt <- nodeTest as
pr <- many predicate
return (Step as nt pr)
<?> "step"
axisSpecifier' :: XParser AxisSpec
axisSpecifier'
= do
tokenParser (symbol "@")
return Attribute
<|>
do
as <- option Child ( try ( do
a <- axisSpecifier
tokenParser (symbol "::")
return a
)
)
return as
<?> "axisSpecifier'"
axisSpecifier :: XParser 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 -> XParser 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 :: XParser String
pI
= do
tokenParser (symbol n_processing_instruction)
li <- between lpar rpar literal
return li
<?> "Processing-Instruction"
predicate :: XParser Expr
predicate
= do
ex <- between lbra rbra expr
return ex
abbrStep :: XParser XStep
abbrStep
= do
tokenParser (symbol "..")
return (Step Parent (TypeTest XPNode) [])
<|>
do
tokenParser (symbol ".")
return (Step Self (TypeTest XPNode) [])
<?> "abbrStep"
expr :: XParser Expr
expr = orExpr
primaryExpr :: XParser 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 :: XParser Expr
functionCall
= do
fn <- functionName
arg <- between lpar rpar ( sepBy expr (separator ',') )
return (FctExpr fn arg)
<?> "functionCall"
unionExpr :: XParser Expr
unionExpr
= do
e1 <- pathExpr
eRest <- many (exprRest unionOp pathExpr)
return (mkExprNode e1 eRest)
pathExpr :: XParser 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 :: XParser Expr
filterExpr
= do
prim <- primaryExpr
predicates <- many predicate
if length predicates > 0
then return (FilterExpr (prim : predicates))
else return prim
<?> "filterExpr"
orExpr :: XParser Expr
orExpr
= do
e1 <- andExpr
eRest <- many (exprRest orOp andExpr)
return (mkExprNode e1 eRest)
<?> "orExpr"
andExpr :: XParser Expr
andExpr
= do
e1 <- equalityExpr
eRest <- many (exprRest andOp equalityExpr)
return (mkExprNode e1 eRest)
<?> "andExpr"
equalityExpr :: XParser Expr
equalityExpr
= do
e1 <- relationalExpr
eRest <- many (exprRest eqOp relationalExpr)
return (mkExprNode e1 eRest)
<?> "equalityExpr"
relationalExpr :: XParser Expr
relationalExpr
= do
e1 <- additiveExpr
eRest <- many (exprRest relOp additiveExpr)
return (mkExprNode e1 eRest)
<?> "relationalExpr"
additiveExpr :: XParser Expr
additiveExpr
= do
e1 <- multiplicativeExpr
eRest <- many (exprRest addOp multiplicativeExpr)
return (mkExprNode e1 eRest)
<?> "additiveExpr"
multiplicativeExpr :: XParser Expr
multiplicativeExpr
= do
e1 <- unaryExpr
eRest <- many (exprRest multiOp unaryExpr)
return (mkExprNode e1 eRest)
<?> "multiplicativeExpr"
unaryExpr :: XParser Expr
unaryExpr
= do
tokenParser (symbol "-")
u <- unaryExpr
return (GenExpr Unary [u])
<|>
do
u <- unionExpr
return u
<?> "unaryExpr"
literal :: XParser String
literal = systemLiteral
number :: XParser 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 :: XParser String
functionName
= try ( do
(p, n) <- qName
uris <- getState
u <- return $ if null p
then ""
else '{' : show (lookupNs uris (newXName p)) ++ "}"
let fn = (u ++ n) in
if fn `elem` ["processing-instruction", "comment", "text", "node"]
then fail ("function name: " ++ fn ++ "not allowed")
else return fn
)
<?> "functionName"
variableReference :: XParser (String, String)
variableReference
= do
tokenParser (symbol "$")
(p,n) <- qName
uris <- getState
return (show (lookupNs uris (newXName p)), n)
<?> "variableReference"
nameTest :: AxisSpec -> XParser QName
nameTest as
= do tokenParser (symbol "*")
uris <- getState
return (enhanceQN as uris $ mkPrefixLocalPart "" "*")
<|>
try ( do pre <- ncName
_ <- symbol ":*"
uris <- getState
return (enhanceQN as uris $ mkPrefixLocalPart pre "*")
)
<|>
do (pre,local) <- qName
uris <- getState
return (enhanceQN as uris $ mkPrefixLocalPart pre local)
<?> "nameTest"
nodeType' :: XParser XPathNode
nodeType'
= do
nt <- nodeType
lpar
rpar
return nt
<?> "nodeType'"
nodeType :: XParser XPathNode
nodeType
= choice [ symbolParser (n_comment, XPCommentNode)
, symbolParser (n_text, XPTextNode)
, symbolParser (n_processing_instruction, XPPINode)
, symbolParser (n_node, XPNode)
]
<?> "nodeType"