From c6939d3bc658347f4ee1b1b687f91e9428a59b6d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 9 Dec 2023 00:14:34 +0100 Subject: Rework namespaced sxml type. Still incomplete. --- tests/unit/sxml/sxml-namespaced.scm | 108 ++++++++++++++++++++++-------------- 1 file changed, 65 insertions(+), 43 deletions(-) (limited to 'tests/unit/sxml/sxml-namespaced.scm') 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 "")) - (test-equal - `(*TOP* (,(xml 'ns1 'tag))) + (test-equal "With default namespace" + (xml-document + root: ((xml 'ns1 'tag))) (xml->namespaced-sxml "")) - (test-equal - `(*TOP* (,(xml 'ns2 'tag))) + (test-equal "With unused default namespace" + (xml-document + root: ((xml 'ns2 'tag))) (xml->namespaced-sxml "")) - (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 "")) (test-equal "PI are passed directly" - `(*TOP* ,(pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") - (,(xml 'tag))) - (xml->namespaced-sxml "")) + (xml-document + pi: (list (pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"")) + root: ((xml 'tag))) + (xml->namespaced-sxml "")) (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 " " 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 " "))) @@ -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) #\:)) -- cgit v1.2.3