Rework namespaced sxml type. Still incomplete.

1 files changed, 65 insertions, 43 deletions

diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm
index 52f86303..18e35225 100644
--- a/tests/unit/sxml/sxml-namespaced.scm
+++ b/tests/unit/sxml/sxml-namespaced.scm
@@ -9,6 +9,15 @@
 
 ;;; TODO tests with attributes
 
+(test-equal
+    (pi-element 'xml "version=\"1.0\"")
+  (sxml->namespaced-sxml
+   '(*PI* xml "version=\"1.0\"")
+   '()))
+
+
+
+
 (define (ns x)
   (string->symbol (format #f "http://example.com/~a" x)))
 
@@ -19,56 +28,64 @@
 
 (test-group "XML constructor utility procedure"
   (test-equal "3 args"
-    (xml-element tag: 'tagname ns: 'namespace attributes: '())
-    (xml 'namespace 'tagname '()))
+    (xml-element tag: 'tagname ns: 'namespace)
+    ((xml 'namespace 'tagname '())))
 
   (test-equal "2 args"
-    (xml-element tag: 'tagname ns: 'namespace attributes: '())
-    (xml 'namespace 'tagname))
+    (xml-element tag: 'tagname ns: 'namespace)
+    ((xml 'namespace 'tagname)))
 
   (test-equal "1 args"
-    (xml-element tag: 'tagname attributes: '())
-    (xml 'tagname)))
+    (xml-element tag: 'tagname)
+    ((xml 'tagname))))
+
+;;; TODO Attributes
+;;; TODO children
 
 
 
 (test-group "xml->namespaced-sxml"
 
-  (test-equal
-      `(*TOP* (,(xml 'tag)))
+  (test-equal "Without namespace"
+    (xml-document
+     root: ((xml 'tag)))
     (xml->namespaced-sxml "<tag/>"))
 
-  (test-equal
-      `(*TOP* (,(xml 'ns1 'tag)))
+  (test-equal "With default namespace"
+    (xml-document
+     root: ((xml 'ns1 'tag)))
     (xml->namespaced-sxml "<tag xmlns='ns1'/>"))
 
-  (test-equal
-      `(*TOP* (,(xml 'ns2 'tag)))
+  (test-equal "With unused default namespace"
+    (xml-document
+     root: ((xml 'ns2 'tag)))
     (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'/>"))
 
-  (test-equal
-      `(*TOP* (,(xml 'ns2 'tag)
-               (,(xml 'ns1 'tag))))
+  (test-equal "With multiple namespaces"
+    (xml-document
+     root: ((xml 'ns2 'tag)
+            ((xml 'ns1 'tag))))
     (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>"))
 
   (test-equal "PI are passed directly"
-      `(*TOP* ,(pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"")
-              (,(xml 'tag)))
-      (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>"))
+    (xml-document
+     pi: (list (pi-element 'xml "encoding=\"utf-8\" version=\"1.0\""))
+     root: ((xml 'tag)))
+    (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>"))
 
   (test-equal "Document with whitespace in it"
-    `(*TOP* ,(pi-element 'xml "")
-            (,(xml 'root)
-             " "
-             (,(xml 'a))
-             ))
+    (xml-document
+     pi: (list (pi-element 'xml ""))
+     root: ((xml 'root)
+            " "
+            ((xml 'a))))
     (xml->namespaced-sxml "<?xml?><root> <a/></root>"
                           trim-whitespace?: #f))
 
-  ;; TODO is this expected? xml->sxml discards it.
-  (test-equal "Whitespace before root is kept"
-    `(*TOP* ,(pi-element 'xml "")
-            (,(xml 'root)))
+  (test-equal "Whitespace before root is discarded kept"
+    (xml-document
+     pi: (list (pi-element 'xml ""))
+     root: ((xml 'root)))
     (xml->namespaced-sxml "<?xml?> <root/>")))
 
 
@@ -77,21 +94,27 @@
 ;;; attributes, since xml->sxml doesn't have those.
 (test-group "sxml->namespaced-sxml"
   (test-equal "Simplest"
-    `(,(xml 'a)) (sxml->namespaced-sxml '(a) '()))
+    ((xml 'a))
+    (sxml->namespaced-sxml '(a) '()))
+
   (test-equal "With *TOP*"
-    `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '()))
+    (xml-document root: ((xml 'a)))
+    (sxml->namespaced-sxml '(*TOP* (a)) '()))
+
   (test-equal "Simplest with namespace"
-    `(,(xml (ns 1) 'a))
+    ((xml (ns 1) 'a))
     (sxml->namespaced-sxml '(x:a)
                            `((x . ,(ns 1)))))
+
   (test-equal "With pi"
-    `(*TOP* ,(pi-element 'xml "test")
-            (,(xml 'a)))
+    (xml-document root: ((xml 'a))
+                  pi: (list (pi-element 'xml "test")))
     (sxml->namespaced-sxml
      `(*TOP*
        (*PI* xml "test")
        (a))
      '()))
+
   (test-error "With unknown namespace"
     'missing-namespace
     (sxml->namespaced-sxml '(x:a) '())))
@@ -106,8 +129,7 @@
        (call-with-values
            (lambda ()
              (namespaced-sxml->sxml/namespaces
-              `(*TOP*
-                (,(xml 'a)))))
+              (xml-document root: ((xml 'a)))))
          (lambda (tree namespaces)
            (test-equal `(*TOP* (a)) tree)
            (test-equal '() namespaces))))
@@ -116,10 +138,10 @@
      (call-with-values
          (lambda ()
            (namespaced-sxml->sxml/namespaces
-            `(*TOP*
-              (,(xml (ns 1) 'a)
-               (,(xml (ns 2) 'a))
-               (,(xml 'a))))))
+            (xml-document
+             root: ((xml (ns 1) 'a)
+                    ((xml (ns 2) 'a))
+                    ((xml 'a))))))
        (lambda (tree nss)
          (test-eqv 2 (length nss))
          (test-equal
@@ -133,9 +155,9 @@
      (call-with-values
          (lambda ()
            (namespaced-sxml->sxml/namespaces
-            `(*TOP*
-              ,(pi-element 'xml "test")
-              (,(xml 'a)))))
+            (xml-document
+             pi:   (list (pi-element 'xml "test"))
+             root: ((xml 'a)))))
        (lambda (tree namespaces)
          (test-equal '() namespaces)
          (test-equal `(*TOP* (*PI* xml "test")
@@ -145,10 +167,10 @@
   (test-group "namespaced-sxml->sxml"
     (test-equal "Without namespaces"
       '(*TOP* (a (@)))
-      (namespaced-sxml->sxml `(*TOP* (,(xml 'a)))))
+      (namespaced-sxml->sxml (xml-document root: ((xml 'a)))))
 
     (test-group "With namespaces"
-     (match (namespaced-sxml->sxml `(*TOP* (,(xml (ns 1) 'a))))
+     (match (namespaced-sxml->sxml (xml-document root: ((xml (ns 1) 'a))))
        ;; (ns 1) hard coded to work with match
        (`(*TOP* (,el (@ (,key "http://example.com/1"))))
         (let ((el-pair  (string-split (symbol->string el) #\:))