From ce6c337da3183395f8f628a593bcc9f89711a34b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 12 Jul 2020 23:26:11 +0200
Subject: SXML Namespace mappings.

---
 module/sxml/namespace.scm | 33 +++++++++++++++++++++++++++------
 1 file changed, 27 insertions(+), 6 deletions(-)

diff --git a/module/sxml/namespace.scm b/module/sxml/namespace.scm
index 4e364cad..5a274098 100644
--- a/module/sxml/namespace.scm
+++ b/module/sxml/namespace.scm
@@ -12,11 +12,32 @@
 (define (string-last string)
   (string-ref string (1- (string-length string))))
 
-;; sxml, (U symbol string #f) → sxml
-;; NOTE possibly allow namespace to be a map between namespaces
-(define-public (move-to-namespace sxml namespace)
 
-  (define nssymb
+;; Change the namespace for all tags in a given SXML tree.
+;; Takes either a fix namespace everything is moved to, or
+;; an assoc list which maps input namespaces to output namespaces.
+;; A namespace is a symbol, string, or #f for no namespace.
+;; keys in the assoc list can't be strings.
+;; @example
+;; (move-to-namespace '(test) '((#f . NEW)))
+;; => (NEW:test)
+;; (move-to-namespace '(a:a (b:b)) '((a . b) (b . a)))
+;; => (b:a (a:b))
+;; (move-to-namespace '(a:a (b:b)) #f)
+;; => (a (b))
+;; (move-to-namespace '(a:a (b:b)) 'c)
+;; => (c:a (c:b))
+;; @end example
+;; sxml, (U symbol string #f (alist (U #f symbol) (U symbol string #f))) → sxml
+(define-public (move-to-namespace sxml namespace-map)
+
+  (define (nssymb key)
+    (define namespace
+      (if (list? namespace-map)
+          (or (assoc-ref namespace-map key)
+              (error "No mapping for namespace" key))
+          namespace-map))
+
     (cond
      [(not namespace) '#{}#]
      [(symbol? namespace)
@@ -30,8 +51,8 @@
   (define (ns tag)
     (call-with-values (lambda () (symbol-split tag))
       (case-lambda
-        [(ns tag) (symbol-append nssymb tag)]
-        [(tag) (symbol-append nssymb tag)])))
+        [(ns tag) (symbol-append (nssymb ns) tag)]
+        [(tag) (symbol-append (nssymb #f) tag)])))
 
   (pre-post-order
    sxml
-- 
cgit v1.2.3