From e400209384796fa4599b6d4885dd4166e59a3b5c Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 13 Jul 2021 16:30:51 +1200
Subject: [PATCH] Attempted integration of XPath selectors.

---
 src/Internal/Elements.hs       |  3 +++
 src/Internal/Elements/XPath.hs | 26 +++++++++++++-------------
 src/UI/Search.hs               |  1 +
 3 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/src/Internal/Elements.hs b/src/Internal/Elements.hs
index 7626dbf..974149a 100644
--- a/src/Internal/Elements.hs
+++ b/src/Internal/Elements.hs
@@ -47,6 +47,9 @@ find (Find "css selector" sel) root = case CSS.parsePath sel of
 find (Find "link text" sel) root = Right $ allLinks (== pack sel) root
 find (Find "partial link text" sel) root = Right $ allLinks (Txt.isInfixOf $ pack sel) root
 find (Find "tag name" sel) root = Right (X.descendant root >>= X.checkName (== fromString sel))
+find (Find "xpath" sel) root = case XPath.runXPath root $ Txt.pack sel of
+    Right res -> Right res
+    Left msgs -> Left (True, Prelude.unlines msgs)
 find (Find type_ _) _ = Left (False, "Invalid selector type: " ++ Txt.unpack type_)
 
 allLinks test = X.descendant X.>=>
diff --git a/src/Internal/Elements/XPath.hs b/src/Internal/Elements/XPath.hs
index 13f6d07..f2efaad 100644
--- a/src/Internal/Elements/XPath.hs
+++ b/src/Internal/Elements/XPath.hs
@@ -20,19 +20,7 @@ import Text.Read (readMaybe)
 data Context = Context {
         item :: [Value],
         vars :: M.Map Name [Value],
-        funcs :: M.Map (Name, Int) (Context -> [[Value]] -> [Value]),
-        timestamp :: ZonedTime,
-        timezone :: TimeZone,
-        lang :: Text,
-        calendar :: Text,
-        place :: Text, -- Noop?
-        docs :: M.Map Name Document,
-        texts :: M.Map Text Text,
-        collections :: M.Map Text [Value],
-        collection :: [Value],
-        uriCollections :: M.Map Text [Text],
-        uriCollection :: [Text],
-        environment :: M.Map Text Text
+        funcs :: M.Map (Name, Int) (Context -> [[Value]] -> [Value])
     }
 
 ---- Typesystem/coercion
@@ -565,3 +553,15 @@ fnMathATan _ [x'] | Right x <- num x' = [Number $ atan x]
 fnMathATan _ _ = typeError
 fnMathATan2 _ [y', x'] | Right x <- num x', Right y <- num y' = [Number $ atan2 y x]
 fnMathATan2 _ _ = typeError
+
+---- Public API
+runXPath' node sel = case parseXPath sel of
+    Right ast -> evals Context {
+            item = [Node node],
+            vars = M.empty,
+            funcs = stdLib
+        } ast
+    Left err -> [Error "err:syntax" err ""]
+runXPath node sel = let ret = runXPath' node sel
+    in if any isErr ret then Left [msg | Error name msg _ <- ret]
+    else Right [n | Node n <- ret]
diff --git a/src/UI/Search.hs b/src/UI/Search.hs
index f3d98b7..ab73f84 100644
--- a/src/UI/Search.hs
+++ b/src/UI/Search.hs
@@ -28,6 +28,7 @@ engines = [
     (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...
   ]
 
 result href' = a ! href (stringValue href') ! target "preview"
-- 
2.30.2