@@ 0,0 1,680 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Internal.Elements.XPathParse(parseXPath, parseQName,
+ Quantifier(..), Quantity(..), MaybePair(..), XType(..), Value(..), val2type, isErr,
+ Expression(..), Arrow(..), PathComp(..), PrimaryExpr(..), PostExpr(..),
+ Key(..), Axis'(..), SomeEvery(..)) where
+
+import Data.Attoparsec.Text.Lazy
+import Control.Applicative
+import Data.Text (Text(..), pack)
+
+import Text.XML.Cursor
+import Text.XML (Name(..), Node(..))
+import qualified Data.Map.Strict as M
+
+skipSpace' = do
+ skipSpace
+ option () $ do
+ char '('
+ char ':'
+ manyTill anyChar $ string ":)"
+ skipSpace
+pSpaced :: Parser a -> Parser a
+pSpaced act = do
+ skipSpace'
+ ret <- act
+ skipSpace'
+ return ret
+-- Transliterated from grammar at https://www.w3.org/TR/xpath-3/#nt-bnf
+parseXPath = parseOnly pExpr
+
+pParamList = do
+ head <- pParam
+ tail <- many' $ do
+ char ','
+ pParam
+ return (head:tail)
+pParam = do
+ skipSpace'
+ char '$'
+ name <- pEQName
+ skipSpace'
+ type_ <- option (Quantity TypeItem None Many) $ pTypeDeclaration
+ return (name, type_)
+pFunctionBody = pEnclosedExpr
+pEnclosedExpr = pSpaced $ do
+ char '{'
+ ret <- option [] $ pExpr
+ char '}'
+ return ret
+pExpr :: Parser [Expression]
+pExpr = do
+ head <- pExprSingle
+ tail <- many' $ do
+ char ','
+ pExprSingle
+ return (head:tail)
+pExprSingle = pSpaced (pForExpr <|> pLetExpr <|> pQuantifiedExpr <|> pIfExpr <|> pOrExpr)
+
+pForExpr = do
+ header <- pSimpleForClause
+ string "return"
+ body <- pExprSingle
+ return $ foldr (\(var, val) body' -> ExprFor var val body') body header
+pSimpleForClause = do
+ string "for"
+ head <- pSimpleForBinding
+ tail <- many' $ do
+ char ','
+ pSimpleForBinding
+ return (head:tail)
+pSimpleForBinding = do
+ skipSpace'
+ char '$'
+ var <- pVarName
+ skipSpace' >> char 'i' >> char 'n'
+ val <- pExprSingle
+ return (var, val)
+
+pLetExpr = do
+ header <- pSimpleLetClause
+ string "return"
+ body <- pExprSingle
+ return $ foldr (\(var, val) body' -> ExprLet var val body') body header
+pSimpleLetClause = do
+ string "let"
+ head <- pSimpleLetBinding
+ tail <- many' $ do
+ char ','
+ pSimpleLetBinding
+ return (head:tail)
+pSimpleLetBinding = do
+ skipSpace'
+ char '$'
+ var <- pVarName
+ skipSpace' >> char ':' >> char '='
+ val <- pExprSingle
+ return (var, val)
+
+pQuantifiedExpr = do
+ quantifier <- (string "some" >> return Some) <|> (string "every" >> return Every)
+ head <- pSimpleForBinding
+ tail <- many' $ do
+ char ','
+ pSimpleForBinding
+ string "satisfies"
+ body <- pExprSingle
+ return $ ExprQuantified quantifier $
+ foldr (\(var, val) body' -> ExprFor var val body') body (head:tail)
+
+pIfExpr = do
+ char 'i' >> char 'f'
+ skipSpace' >> char '('
+ test <- pExpr
+ char ')' >> skipSpace'
+ string "then"
+ pass <- pExprSingle
+ string "else"
+ fail <- pExprSingle
+ return $ ExprIf test pass fail
+
+pOrExpr = do
+ a <- pAndExpr
+ bs <- many' $ do
+ pSpaced (char 'o' >> char 'r')
+ pAndExpr
+ return $ if null bs then a else ExprOr (a:bs)
+pAndExpr = do
+ a <- pComparisonExpr
+ bs <- many' $ do
+ pSpaced $ string "and"
+ pComparisonExpr
+ return $ if null bs then a else ExprAnd (a:bs)
+pComparisonExpr = do
+ a <- pStringConcatExpr
+ option a $ do
+ skipSpace'
+ op <- pValueComp <|> pGeneralComp <|> pNodeComp -- TODO implement comparisons
+ skipSpace'
+ b <- pStringConcatExpr
+ return $ op a b
+pStringConcatExpr = do
+ a <- pRangeExpr
+ bs <- many' $ do
+ pSpaced (char '|' >> char '|')
+ pRangeExpr
+ return $ if null bs then a else ExprStrConcat (a:bs)
+pRangeExpr = do
+ a <- pAdditiveExpr
+ option a $ do
+ pSpaced (char 't' >> char 'o')
+ b <- pAdditiveExpr
+ return $ ExprRange a b
+pAdditiveExpr = do
+ a <- pMultiplicativeExpr
+ bs <- many' $ do
+ op <- pSpaced ((char '-' >> return ExprNegate) <|> (char '+' >> return id))
+ b <- pMultiplicativeExpr
+ return $ op b
+ return $ if null bs then a else ExprSum (a:bs)
+pMultiplicativeExpr = do
+ a <- pUnionExpr
+ bs <- many' $ do
+ skipSpace'
+ op <- (char '*' >> return ExprMul) <|> (string "div" >> return ExprDiv) <|>
+ (string "idiv" >> return ExprIDiv) <|> (string "mode" >> return ExprMod)
+ skipSpace'
+ b <- pUnionExpr
+ return (`op` b)
+ return $ foldl (\a b -> b a) a bs
+pUnionExpr = do
+ a <- pIntersectExceptExpr
+ bs <- many' $ do
+ pSpaced (string "union" <|> string "|")
+ pIntersectExceptExpr
+ return $ ExprUnion (a:bs)
+pIntersectExceptExpr = do
+ a <- pInstanceOfExpr
+ bs <- many' $ do
+ op <- pSpaced ((string "intersect" >> return ExprIntersect) <|>
+ (string "except" >> return ExprExcept))
+ b <- pInstanceOfExpr
+ return (`op` b)
+ return $ foldl (\a b -> b a) a bs
+pInstanceOfExpr = do
+ a <- pTreatExpr
+ option a $ do
+ pSpaced (string "instance" >> skipSpace' >> char 'o' >> char 'f')
+ type_ <- pSequenceType
+ return $ ExprInstanceOf a type_
+pAs = pSpaced (char 'a' >> char 's')
+pTreatExpr = do
+ a <- pCastableExpr
+ option a $ do
+ skipSpace' >> string "treat" >> pAs
+ type_ <- pSequenceType
+ return $ ExprTreatAs a type_
+pCastableExpr = do
+ a <- pCastExpr
+ option a $ do
+ skipSpace' >> string "castable" >> pAs
+ type_ <- pSingleType
+ return $ ExprCastableAs a type_
+pCastExpr = do
+ a <- pArrowExpr
+ option a $ do
+ skipSpace' >> string "cast" >> pAs
+ type_ <- pSingleType
+ return $ ExprCastAs a type_
+pArrowExpr = do
+ a <- pUnaryExpr
+ bs <- many' $ do
+ pSpaced (char '=' >> char '>')
+ spec <- pArrowFunctionSpecifier
+ args <- pArgumentList
+ return (spec, args)
+ return $ foldl (\a (spec, args) -> ExprArrow a spec args) a bs
+pUnaryExpr = do
+ ops <- many' $ pSpaced (char '+' <|> char '-')
+ a <- pValueExpr
+ return $ if length (filter (== '-') ops) `rem` 2 == 1 then ExprNegate a else a
+pValueExpr :: Parser Expression
+pValueExpr = pSimpleMapExpr
+
+char' ch ret = char ch >> return ret
+char'eq ch ret = char ch >> char '=' >> return ret
+char'2 ch ch2 ret= char ch >> char ch2 >> return ret
+pGeneralComp = char' '=' ExprEq <|> char'eq '!' ExprNe <|> char' '<' ExprLt <|>
+ char'eq '<' ExprLe <|> char' '>' ExprGt <|> char'eq '>' ExprGe
+pValueComp = char'2 'e' 'q' ExprEq' <|> char'2 'n' 'e' ExprNe' <|> char'2 'l' 't' ExprLt' <|>
+ char'2 'l' 'e' ExprLe' <|> char'2 'g' 't' ExprGt' <|> char'2 'g' 'e' ExprGe'
+pNodeComp = char'2 'i' 's' ExprIs <|> char'2 '<' '<' ExprPrecedes <|> char'2 '>' '>' ExprFollows
+
+pSimpleMapExpr = do
+ a <- pPathExpr
+ bs <- many' $ do
+ pSpaced $ char '!'
+ pPathExpr
+ return $ foldl ExprMap a bs
+pathHead = PathStep (Axis root, Left $ TypeDocument $ TypeElement Nothing Nothing) []
+pPathExpr = do
+ skipSpace'
+ char '/'
+ tail <- (skipSpace' >> return []) <|> pRelativePathExpr
+ return $ ExprPath (pathHead:tail)
+ <|> do
+ skipSpace'
+ let head2 = PathStep (Axis $ orSelf descendant, Left TypeNode) []
+ char '/' >> char '/'
+ tail <- pRelativePathExpr
+ return $ ExprPath (pathHead:head2:tail)
+ <|> (ExprPath <$> pRelativePathExpr)
+pRelativePathExpr = do
+ a <- pStepExpr
+ bs <- many' $ do
+ char '/'
+ descend <- option False (char '/' >> return True)
+ b <- pStepExpr
+ return $ if descend then [PathStep (Axis $ orSelf descendant, Left TypeNode) [], b] else [b]
+ return (a:concat bs)
+pStepExpr = pPostfixExpr <|> pAxisStep
+pAxisStep = do
+ step <- pReverseStep <|> pForwardStep
+ preds <- pPredicateList
+ return $ PathStep step preds
+pForwardStep = do
+ axis <- pForwardAxis
+ test <- pNodeTest
+ return (axis, test)
+ <|> pAbbrevForwardStep
+string' text ret = string text >> return ret
+pForwardAxis = pSpaced $ do
+ ret <- string' "child" (Axis child) <|>
+ string' "descendant" (Axis descendant) <|>
+ string' "attribute" Attribute <|>
+ string' "self" (Axis self) <|>
+ string' "descendant-or-self" (Axis $ orSelf $ descendant) <|>
+ string' "following-sibling" (Axis followingSibling) <|>
+ string' "following" (Axis following) <|>
+ string' "namespace" Namespace
+ skipSpace' >> char ':' >> char ':'
+ return ret
+pAbbrevForwardStep = do
+ attrs <- pSpaced $ option (Axis child) (char '@' >> return Attribute)
+ test <- pNodeTest
+ return (attrs, test)
+pReverseStep = do
+ axis <- pReverseAxis
+ test <- pNodeTest
+ return (axis, test)
+ <|> pAbbrevReverseStep
+pReverseAxis = pSpaced $ do
+ ret <- string' "parent" (Axis parent) <|>
+ string' "ancestor" (Axis ancestor) <|>
+ string' "preceding-sibling" (Axis precedingSibling) <|>
+ string' "preceding" (Axis preceding) <|>
+ string' "ancestor-or-self" (Axis $ orSelf $ ancestor)
+ skipSpace' >> char ':' >> char ':'
+ return ret
+pAbbrevReverseStep = do
+ pSpaced (char '.' >> char '.')
+ return (Axis parent, Left TypeNode)
+
+pNodeTest = (Left <$> pKindTest) <|> (Right <$> pNameTest)
+pNameTest = pEQName' True
+
+pPostfixExpr = do
+ a <- pPrimaryExpr
+ bs <- many' ((PostFilter <$> pPredicate) <|> (PostCall <$> pArgumentList) <|> (PostLookup <$> pLookup))
+ return $ PostExpr a bs
+pArgumentList = pSpaced $ do
+ char '('
+ head <- pArgument
+ tail <- many' $ do
+ char ','
+ pArgument
+ char ')'
+ return (head:tail)
+pPredicateList = many' pPredicate
+pPredicate = pSpaced $ do
+ skipSpace' >> char '['
+ ret <- pExpr
+ char ']' >> skipSpace'
+ return ret
+pLookup = do
+ pSpaced $ char '?'
+ pKeySpecifier
+pKeySpecifier = (KeyLiteral <$> String <$> show <$> pNCName) <|> (KeyLiteral <$> Number <$> fromIntegral <$> pIntegerLiteral) <|>
+ (KeyExpr <$> pParenthesizedExpr) <|> (pSpaced $ char '*' >> return KeyWildcard)
+
+pArrowFunctionSpecifier = ArrowName <$> pEQName <|> ArrowVar <$> pVarRef <|> ArrowExpr <$> pParenthesizedExpr
+pPrimaryExpr = Literal <$> pLiteral <|> VarRef <$> pVarRef <|> Expr <$> pParenthesizedExpr
+ <|> pContextItemExpr <|> pFunctionCall <|> pFunctionItemExpr <|> UnaryLookup <$> pUnaryLookup <|>
+ MapConstruct <$> pMapConstructor <|> ArrayConstruct <$> pArrayConstructor
+pLiteral = Number <$> pNumericLiteral <|> String <$> pStringLiteral
+pNumericLiteral = double -- I think this matches...
+
+pVarRef = char '$' >> pVarName
+pVarName = pEQName
+pParenthesizedExpr = pSpaced $ do
+ char '('
+ ret <- option [] pExpr
+ char ')'
+ return ret
+pContextItemExpr = char '.' >> return ContextItem
+pFunctionCall = do
+ callee <- pEQName
+ args <- pArgumentList
+ return $ FunctionCall callee args
+pArgument = pExprSingle <|> pArgumentPlaceholder
+pArgumentPlaceholder = char '?' >> return ArgPlaceholder
+pFunctionItemExpr = pNamedFunctionRef <|> pInlineFunctionExpr
+pNamedFunctionRef = do
+ name <- pEQName
+ pSpaced $ char '#'
+ index <- pIntegerLiteral
+ return $ Literal $ FuncRef name index
+pInlineFunctionExpr = do
+ pSpaced $ string "function"
+ char '('
+ params <- pParamList
+ char ')'
+ type_ <- option (Quantity TypeItem None Many) (pAs >> pSequenceType)
+ body <- pFunctionBody
+ return $ FunctionItem params type_ body
+pMapConstructor = do
+ pSpaced $ string "map"
+ char '{'
+ head <- pMapConstructorEntry
+ tail <- many' $ do
+ char ','
+ pMapConstructorEntry
+ char '}'
+ return (head:tail)
+pMapConstructorEntry = do
+ key <- pExprSingle
+ char ':'
+ value <- pExprSingle
+ return (key, value)
+pArrayConstructor = pSquareArrayConstructor <|> pCurlyArrayConstructor
+pSquareArrayConstructor = pSpaced $ do
+ char '['
+ ret <- option [] pExpr
+ char ']'
+ return ret
+pCurlyArrayConstructor = do
+ skipSpace' >> string "array"
+ pEnclosedExpr
+pUnaryLookup = do
+ skipSpace' >> char '?'
+ pKeySpecifier
+pSingleType = do
+ type_ <- pSimpleTypeName
+ optional <- option False (char '?' >> skipSpace' >> return True)
+ return $ if optional then Quantity type_ None One else Quantity type_ One One
+
+pTypeDeclaration = pAs >> pSequenceType
+pSequenceType :: Parser Quantity
+pSequenceType = do
+ skipSpace' >> string "empty-sequence" >> pParens
+ return emptySequence
+ <|> do
+ type_ <- pItemType
+ (low, high) <- option (One, One) $ parseQuantity <$> pOccurrenceIndicator
+ return $ Quantity type_ low high
+pOccurrenceIndicator = char '?' <|> char '*' <|> char '+'
+pParens = pSpaced (char '(' >> skipSpace' >> char ')') >> return ()
+pItemType = pKindTest <|> do
+ skipSpace' >> string "item-type"
+ pParens
+ return TypeItem
+ <|> pFunctionTest <|> pMapTest <|> pArrayTest <|> pAtomicOrUnionType <|> pParenthesizedItemType
+pAtomicOrUnionType = TypeAtomic <$> pEQName
+pKindTest = pDocumentTest <|> pElementTest <|> pAttributeTest <|> pSchemaElementTest <|>
+ pSchemaAttributeTest <|> pPITest <|> pCommentTest <|> pTextTest <|> pNamespaceNodeTest <|> pAnyKindTest
+pAnyKindTest = skipSpace' >> string "node" >> pParens >> return TypeNode
+pDocumentTest = pSpaced $ do
+ string "document-node"
+ skipSpace' >> char '('
+ arg <- pElementTest <|> pSchemaElementTest <|> return (TypeElement Nothing Nothing) -- FIXME What should the default be?
+ char ')'
+ return $ TypeDocument arg
+pTextTest = skipSpace' >> string "text" >> pParens >> return TypeText
+pCommentTest = skipSpace' >> string "comment" >> pParens >> return TypeComment
+pNamespaceNodeTest = skipSpace' >> string "namespace-node" >> pParens >> return TypeNamespaceNode
+pPITest = pSpaced $ do
+ string "processing-instruction"
+ skipSpace' >> char '('
+ arg <- Just <$> pNCName <|> Just <$> pack <$> pStringLiteral <|> return Nothing
+ char ')'
+ return $ TypePI arg
+pAttributeTest = pSpaced $ do
+ string "attribute"
+ skipSpace' >> char '('
+ (attribName, type_) <- option (Nothing, Nothing) $ do
+ attribName <- pAttribNameOrWildcard
+ type_ <- option Nothing $ do
+ char ','
+ Just <$> pTypeName
+ return (attribName, type_)
+ char ')'
+ return $ TypeAttribute attribName type_
+pAttribNameOrWildcard = pSpaced ((Just <$> pAttributeName) <|> (char '*' >> return Nothing))
+pAttributeName = pEQName
+pSchemaAttributeTest = pSpaced $ do
+ string "schema-attribute"
+ skipSpace' >> char '('
+ arg <- pAttributeDeclaration
+ char ')'
+ return $ TypeSchemaAttribute arg
+pAttributeDeclaration = pAttributeName
+pElementTest = pSpaced $ do
+ string "element"
+ pSpaced $ char '('
+ (elName, type_) <- option (Nothing, Nothing) $ do
+ elName <- pElementNameOrWildcard
+ type_ <- option Nothing $ do
+ char ','
+ Just <$> pTypeName
+ return (elName, type_)
+ char ')' >> skipSpace'
+ return $ TypeElement elName type_
+pElementNameOrWildcard = pSpaced ((Just <$> pAttributeName) <|> (char '*' >> return Nothing))
+pElementName = pEQName
+pSchemaElementTest = pSpaced $ do
+ string "schema-element"
+ skipSpace' >> char '('
+ ret <- pElementDeclaration
+ char ')'
+ return $ TypeSchemaElement ret
+pElementDeclaration = pElementName
+pSimpleTypeName = TypeAtomic <$> pTypeName
+pTypeName = pEQName
+pFunctionTest = pAnyFunctionTest <|> pTypedFunctionTest
+pAnyFunctionTest = pSpaced $ do
+ string "function"
+ skipSpace' >> char '(' >> pSpaced (char '*') >> char ')'
+ return $ TypeFunction Nothing'
+pTypedFunctionTest = pSpaced $ do
+ string "function"
+ pSpaced $ char '('
+ args <- option [] $ do
+ head <- pSequenceType
+ tail <- many' $ do
+ char ','
+ pSequenceType
+ return (head:tail)
+ char ')'
+ ret <- option emptySequence $ do
+ pAs
+ pSequenceType
+ return $ TypeFunction $ Some' args ret
+pMapTest = pAnyMapTest <|> pTypedMapTest
+pAnyMapTest = pSpaced $ do
+ string "map"
+ skipSpace' >> char '(' >> pSpaced (char '*') >> char ')'
+ return $ TypeMap Nothing'
+pTypedMapTest = pSpaced $ do
+ string "map"
+ skipSpace' >> char '('
+ keyType <- pAtomicOrUnionType
+ char ','
+ valType <- pSequenceType
+ char ')'
+ return $ TypeMap $ Some' keyType valType
+pArrayTest = pAnyArrayTest <|> pTypedArrayTest
+pAnyArrayTest = pSpaced $ do
+ skipSpace' >> string "array"
+ skipSpace' >> char '(' >> pSpaced (char '*') >> char ')'
+ return $ TypeArray Nothing
+pTypedArrayTest = pSpaced $ do
+ string "array" >> skipSpace'
+ char '('
+ type_ <- pSequenceType
+ char ')'
+ return $ TypeArray $ Just type_
+pParenthesizedItemType = pSpaced $ do
+ char '('
+ ret <- pItemType
+ char ')'
+ return ret
+pEQName = pEQName' False
+pEQName' wildcard = pQName wildcard <|> pURIQualifiedName wildcard
+
+--- Terminals
+pIntegerLiteral = read <$> pSpaced pDigits
+pStringLiteral :: Parser String
+pStringLiteral = pSpaced (pStringLiteral' '\'' <|> pStringLiteral' '"')
+pStringLiteral' qt = do
+ char qt
+ ret <- many' (pEscapeQuote qt <|> notChar qt)
+ char qt
+ return ret
+pBracedURILiteral = pSpaced $ do
+ char 'Q'
+ char '{'
+ ret <- takeWhile1 (`notElem` ['{', '}'])
+ char '}'
+ return ret
+pEscapeQuote qt = char qt >> char qt
+pDigits = many1 digit
+
+
+-- XML grammar rules referenced by XPath
+-- This is copied from XML Conduit rather than transliterated from the standard
+-- because Attoparsec can't recognize (but can preserve) Unicode characters
+pNCName = pSpaced $ pNCName' False
+pNCName' isWildcard = takeWhile1 valid <?> "identifier"
+ where
+ valid '*' = isWildcard
+ valid '&' = False
+ valid '<' = False
+ valid '>' = False
+ valid ':' = False
+ valid '?' = False
+ valid '=' = False
+ valid '"' = False
+ valid '\'' = False
+ valid '/' = False
+ valid ';' = False
+ valid '#' = False
+ valid c = not $ isXMLSpace c
+
+isXMLSpace :: Char -> Bool
+isXMLSpace ' ' = True
+isXMLSpace '\t' = True
+isXMLSpace '\r' = True
+isXMLSpace '\n' = True
+isXMLSpace _ = False
+
+parseQName :: Text -> Either String Name
+parseQName = parseOnly $ pQName False
+pQName isWildcard = pSpaced $ do
+ ns <- option Nothing $ do
+ ret <- pNCName' isWildcard
+ char ':'
+ return $ Just ret
+ name <- pNCName' isWildcard
+ return $ Name name Nothing ns
+pURIQualifiedName isWildcard = pSpaced $ do
+ ns <- pBracedURILiteral
+ name <- pNCName' isWildcard
+ return $ Name name (Just ns) Nothing
+
+--- Type Modelling
+data Quantifier = None | One | Many deriving (Eq, Show)
+parseQuantity '?' = (None, One)
+parseQuantity '*' = (None, Many)
+parseQuantity '+' = (One, Many)
+
+data Quantity = Quantity XType Quantifier Quantifier deriving (Eq, Show)
+emptySequence = Quantity TypeItem None None
+
+data MaybePair a b = Nothing' | Some' a b deriving (Eq, Show)
+
+data XType = TypeDocument XType |
+ TypeElement (Maybe Name) (Maybe Name) |
+ TypeArray (Maybe Quantity) |
+ TypeMap (MaybePair XType Quantity) |
+ TypeFunction (MaybePair [Quantity] Quantity) |
+ TypeSchemaElement Name |
+ TypeNode |
+ TypeNamespaceNode |
+ TypeText |
+ TypeComment |
+ TypePI (Maybe Text) |
+ TypeSchemaAttribute Name |
+ TypeAttribute (Maybe Name) (Maybe Name) |
+ TypeAtomic Name |
+ TypeItem deriving (Eq, Show)
+
+--- Abstract Syntax Tree
+data Expression = ExprFor Name Expression Expression |
+ ArgPlaceholder |
+ ExprLet Name Expression Expression |
+ ExprQuantified SomeEvery Expression |
+ ExprIf [Expression] Expression Expression |
+ ExprOr [Expression] |
+ ExprAnd [Expression] |
+ ExprStrConcat [Expression] |
+ ExprRange Expression Expression |
+ ExprNegate Expression |
+ ExprSum [Expression] |
+ ExprFollows Expr Expr | ExprPrecedes Expr Expr | ExprIs Expr Expr |
+ ExprGe Expr Expr | ExprGt Expr Expr | ExprLe Expr Expr | ExprLt Expr Expr | ExprNe Expr Expr | ExprEq Expr Expr |
+ ExprGe' Expr Expr | ExprGt' Expr Expr | ExprLe' Expr Expr | ExprLt' Expr Expr | ExprNe' Expr Expr | ExprEq' Expr Expr |
+ ExprMod Expr Expr | ExprIDiv Expr Expr | ExprDiv Expr Expr | ExprMul Expr Expr |
+ ExprUnion [Expression] | ExprIntersect Expr Expr | ExprExcept Expr Expr |
+ ExprArrow Expression Arrow [Expression] |
+ ExprCastAs Expr Quantity | ExprCastableAs Expr Quantity | ExprTreatAs Expr Quantity | ExprInstanceOf Expr Quantity |
+ ExprMap Expression Expression |
+ ExprPath [PathComp]
+type Expr = Expression
+
+data SomeEvery = Some | Every
+
+data Arrow = ArrowName Name | ArrowVar Name | ArrowExpr [Expression]
+
+data PathComp = PostExpr PrimaryExpr [PostExpr] | PathStep (Axis', Either XType Name) [[Expression]]
+
+data PrimaryExpr = Literal Value | VarRef Name | Expr [Expression] | ContextItem |
+ FunctionCall Name [Expression] | FunctionItem [(Name, Quantity)] Quantity [Expression] |
+ MapConstruct [(Expr, Expr)] | ArrayConstruct [Expression] | UnaryLookup Key
+
+data PostExpr = PostFilter [Expression] | PostCall [Expression] | PostLookup Key
+
+data Key = KeyExpr [Expression] | KeyWildcard | KeyLiteral Value
+
+data Axis' = Axis Axis | Attribute | Namespace
+
+--- Runtime
+
+data Value = Number Double | String String | Bool Bool | Node Cursor | Error Name String String |
+ Array [[Value]] | Map (M.Map String [Value]) | PartialFunc [Expression] Value |
+ FuncRef Name Int | Function [(Name, Quantity)] Quantity [Expression] (M.Map Name [Value])
+
+instance Eq Value where
+ Number x == Number y = x == y
+ String x == String y = x == y
+ Bool x == Bool y = x == y
+ Node x == Node y = node x == node y
+ Error x0 x1 x2 == Error y0 y1 y2 = x0 == y0 && x1 == y1 && x2 == y2
+ Array x == Array y = x == y
+ Map x == Map y = x == y
+ FuncRef x0 x1 == FuncRef y0 y1 = x0 == y0 && x1 == y1
+ _ == _ = False
+
+val2type (Number _) = TypeAtomic "xsd:double"
+val2type (String _) = TypeText
+val2type (Bool _) = TypeAtomic "xsd:bool"
+val2type (Node _) = TypeNode
+val2type (Error _ _ _) = TypeAtomic "xsd:error"
+val2type (Array _) = TypeArray Nothing
+val2type (Map _) = TypeMap Nothing'
+val2type (Function _ _ _ _) = TypeFunction Nothing'
+
+isErr (Error _ _ _) = True
+isErr _ = False
+
+self cursor = [cursor]
+root = ancestor >=> check (null . ancestor)
@@ 27,8 27,8 @@ engines = [
(const "URL", offerToLoad),
(const "CSS", queryEls "css selector"),
(flip l LinkSearchExact, queryEls "link text"), -- Only useful if it promotes results higher.
- (flip l LinkSearch, queryEls "partial link text")
--- (const "XPath", queryEls "xpath") -- FIXME parser infinite loops...
+ (flip l LinkSearch, queryEls "partial link text"),
+ (const "XPath", queryEls "xpath") -- FIXME parser infinite loops...
]
result href' = a ! href (stringValue href') ! target "preview"