From f33ba8749a39958e587752f247608f1e17484511 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 15 Jul 2021 13:41:39 +1200
Subject: [PATCH] Fix infinite loop in XPath parser preventing UI integration.

---
 src/Internal/Elements/XPathParse.hs | 680 ++++++++++++++++++++++++++++
 src/UI/Search.hs                    |   4 +-
 2 files changed, 682 insertions(+), 2 deletions(-)
 create mode 100644 src/Internal/Elements/XPathParse.hs

diff --git a/src/Internal/Elements/XPathParse.hs b/src/Internal/Elements/XPathParse.hs
new file mode 100644
index 0000000..99da36b
--- /dev/null
+++ b/src/Internal/Elements/XPathParse.hs
@@ -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)
diff --git a/src/UI/Search.hs b/src/UI/Search.hs
index e4b748f..605c2ea 100644
--- a/src/UI/Search.hs
+++ b/src/UI/Search.hs
@@ -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"
-- 
2.30.2