From 4e76833eb8392d4a7e75b6f8836a77f8d4f01f3d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 23 Dec 2023 17:00:53 +0100
Subject: Start work on namespaced xpath.

---
 module/sxml/namespaced/xpath.scm     | 176 +++++++++++++++++++++++++++++++++++
 tests/unit/sxml/namespaced-xpath.scm |  28 ++++++
 2 files changed, 204 insertions(+)
 create mode 100644 module/sxml/namespaced/xpath.scm
 create mode 100644 tests/unit/sxml/namespaced-xpath.scm

diff --git a/module/sxml/namespaced/xpath.scm b/module/sxml/namespaced/xpath.scm
new file mode 100644
index 00000000..5b8cdb82
--- /dev/null
+++ b/module/sxml/namespaced/xpath.scm
@@ -0,0 +1,176 @@
+(define-module (sxml namespaced xpath)
+  :use-module (ice-9 curried-definitions)
+  :use-module (srfi srfi-1)
+  :export (nodeset?
+           node-typeof?
+           node-eq?
+           node-equal?
+           node-pos
+           filter
+           take-until
+           take-after
+           map-union
+           node-reverse
+           node-trace
+
+           select-kids
+           node-self
+           node-join
+           node-reduce
+           node-or
+           node-closure
+           node-parent
+           sxpath
+           ))
+
+
+;;; Basic Converters and Applicators
+
+(define (node? x)
+  (or (xml-element? x)
+      (table? x)
+      ;; table-entry? x
+      (string? x)
+      (pi-element? x)))
+
+(define (nodeset? x)
+  (every node? x))
+
+
+(define (node-typeof? crit)
+  (case crit
+    ((@) table?)
+    ((*) xml-element*?)
+    ((*text*) string?)
+    ((*PI*) pi-element?)
+    ((*any*) (const #t))
+    (else (and (xml-element*? crit)
+               (xml-element-tagname crit)))))
+
+(define ((node-eq? other) self)
+  (eq? other self))
+
+(define ((node-equal? other) self)
+  (equal? other self))
+
+
+(define ((node-pos n) nodeset)
+  ;; 0 is neither
+  (cond ((positive? n)
+         (list-ref nodeset (1- n)))
+        ((negative? n)
+         (list-ref nodeset
+                   (+ n (length nodeset))))))
+
+(define (filter pred?)
+  'TODO
+  )
+
+
+(define (take-until pred?)
+  ;; TODO
+  )
+
+(define (take-after pred?)
+  ;; TODO
+  )
+
+
+(define (map-union proc lst)
+  ;; TODO this can be really optimized with better data structures
+  (fold (lambda (x done)
+          (let ((result (proc x)))
+            (if (list? result)
+                (append done result)
+                (append done (list result)))))
+        '()
+        lst))
+
+
+(define (node-reverse node-or-nodeset)
+  (if (node? node-or-nodeset)
+      (list node-or-nodeset)
+      (reverse node-or-nodeset)))
+
+(define ((node-trace title) node-or-nodeset)
+  (format #t "~a~%" title)
+  (if (node? node-or-nodeset)
+      (list node-or-nodeset)
+      node-or-nodeset))
+
+
+;;; Converter Combinators
+
+(define ((select-kids test-pred?) node-or-nodeset)
+  (cond ((node? node-or-nodeset)
+         ;; TODO Expand if node has children
+         )
+        (else                         ; Is a nodeset
+         (map-union (select-kids test-pred?) node-or-nodeset))))
+
+(define node-self filter)
+
+
+;;; Takes a list of selectors, and returns a new one
+;;; (node-join f) ⇒ f
+;;; (node-join) ⇒ TODO
+;;; (node-join f g) ⇒ TODO
+(define (node-join . selectors)
+  ;; TODO
+  )
+
+(define ((node-reduce . converters) nodeset)
+  (foldl apply nodeset converters))
+
+(define (node-or . converters)
+  ;; for each converter
+  ;;     get all matching in nodeset
+  ;; then take the union of these
+  ;; Return a new converter with these properties
+  )
+
+
+(define (node-closure test-pred?)
+  (node-or
+   (select-kids test-pred?)
+   (node-reduce (select-kids (node-typeof? '*))
+                (node-closure test-pred?))))
+
+(define (node-parent rootnode)
+  ;; TODO return converter
+  )
+
+
+
+(define (sxpath path)
+  (match path
+    ('() (node-join))
+    ((x xs ...) (node-join (sxpath1 x) (sxpath xs)))))
+
+
+(define (sxpath1 x)
+  (match x
+    ('//
+     (node-or
+      ;; The node itself
+      (node-self (node-typeof? '*any*))
+      ;; All ((...) grand) children
+      (node-closure (node-typeof? '*any*))))
+    (('equal? x)
+     (select-kids (node-equal? x)))
+    (('eq? x)
+     (select-kids (node-eq? x)))
+    ((? symbol? ?symbol)
+     (select-kids (node-typeof? ?symbol)))
+    ((? procedure? procedure)
+     procedure)
+    (((? symbol? ?symbol) rest ...)
+     (sxpath1 `((?symbol) ,@rest)))
+    ((path reducer ...)
+     (apply node-reduce (sxpath path)
+            (map sxpathr reducer)))))
+
+(define (sxpathr x)
+  (cond ((number? x) (node-pos x))
+        (else (filter (sxpath x)))))
+
diff --git a/tests/unit/sxml/namespaced-xpath.scm b/tests/unit/sxml/namespaced-xpath.scm
new file mode 100644
index 00000000..e625d514
--- /dev/null
+++ b/tests/unit/sxml/namespaced-xpath.scm
@@ -0,0 +1,28 @@
+(define-module (test sxml namespaced-xpath)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-64 test-error)
+  :use-module (srfi srfi-88)
+  :use-module ((sxml xpath) :prefix #{x:}#)
+  :use-module (sxml namespaced)
+  :use-module (sxml namespaced util))
+
+(define html '(html (body (a (@ (href "#") (alt "Test")) "Hello")
+                          (a (@ (href "/")) "World"))))
+
+(define xmlns:html 'http://www.w3.org/1999/xhtml)
+
+(define xhtml
+  ((xml xmlns:html 'html)
+   ((xml xmlns:html 'body)
+    ((xml xmlns:html 'a `((href "#") (alt "Test"))) "Hello")
+    ((xml xmlns:html 'a `((href "/"))) "World")
+    ))
+  )
+
+(test-equal
+    (list '(a (@ (href "#") (alt "Test")) "Hello"))
+  ((x:sxpath '(// (a ((@ ((href ((equal? "#")))))))))
+   html))
+
+
+'()
-- 
cgit v1.2.3