From 551828bd29652c5779ecf1e7fbb8278c87c203d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 16 Oct 2023 20:33:16 +0200 Subject: Move sxml tests to own "namespace". --- tests/unit/sxml/sxml-namespaced.scm | 172 ++++++++++++++++++++++++++++++++++++ tests/unit/sxml/xml-namespace.scm | 38 ++++++++ tests/unit/util/sxml-namespaced.scm | 172 ------------------------------------ tests/unit/util/xml-namespace.scm | 38 -------- 4 files changed, 210 insertions(+), 210 deletions(-) create mode 100644 tests/unit/sxml/sxml-namespaced.scm create mode 100644 tests/unit/sxml/xml-namespace.scm delete mode 100644 tests/unit/util/sxml-namespaced.scm delete mode 100644 tests/unit/util/xml-namespace.scm diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm new file mode 100644 index 00000000..b2d55028 --- /dev/null +++ b/tests/unit/sxml/sxml-namespaced.scm @@ -0,0 +1,172 @@ +(define-module (test sxml-namespaced) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (ice-9 match) + :use-module (sxml namespaced) + :use-module (hnh util state-monad) + ) + +;;; TODO tests with attributes + +(define (ns x) + (string->symbol (format #f "http://example.com/~a" x))) + +(define (namespaced-symbol ns symb) + (string->symbol (format #f "~a:~a" ns symb))) + + + +(test-group "XML constructor utility procedure" + (test-equal "3 args" + (make-xml-element 'tagname 'namespace 'attributes) + (xml 'namespace 'tagname 'attributes)) + + (test-equal "2 args" + (make-xml-element 'tagname 'namespace '()) + (xml 'namespace 'tagname)) + + (test-equal "1 args" + (make-xml-element 'tagname #f '()) + (xml 'tagname))) + + + +(test-group "xml->namespaced-sxml" + + (test-equal + `(*TOP* (,(xml 'tag))) + (xml->namespaced-sxml "")) + + (test-equal + `(*TOP* (,(xml 'ns1 'tag))) + (xml->namespaced-sxml "")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag))) + (xml->namespaced-sxml "")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag) + (,(xml 'ns1 'tag)))) + (xml->namespaced-sxml "")) + + (test-equal "PI are passed directly" + `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") + (,(xml 'tag))) + (xml->namespaced-sxml "")) + + (test-equal "Document with whitespace in it" + `(*TOP* ,(make-pi-element 'xml "") + (,(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* ,(make-pi-element 'xml "") + (,(xml 'root))) + (xml->namespaced-sxml " "))) + + + +;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns +;;; attributes, since xml->sxml doesn't have those. +(test-group "sxml->namespaced-sxml" + (test-equal "Simplest" + `(,(xml 'a)) (sxml->namespaced-sxml '(a) '())) + (test-equal "With *TOP*" + `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '())) + (test-equal "Simplest with namespace" + `(,(xml (ns 1) 'a)) + (sxml->namespaced-sxml '(x:a) + `((x . ,(ns 1))))) + (test-equal "With pi" + `(*TOP* ,(make-pi-element 'xml "test") + (,(xml 'a))) + (sxml->namespaced-sxml + `(*TOP* + (*PI* xml "test") + (a)) + '())) + (test-error "With unknown namespace" + 'missing-namespace + (sxml->namespaced-sxml '(x:a) '()))) + + + +(test-group "namespaced-sxml->*" + + ;; /namespaces is the most "primitive" one + (test-group "/namespaces" + (test-group "Without namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal `(*TOP* (a)) tree) + (test-equal '() namespaces)))) + + (test-group "With namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml (ns 1) 'a) + (,(xml (ns 2) 'a)) + (,(xml 'a)))))) + (lambda (tree nss) + (test-eqv 2 (length nss)) + (test-equal + `(*TOP* + (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a) + (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a)) + (a))) + tree)))) + + (test-group "*PI*" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + ,(make-pi-element 'xml "test") + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal '() namespaces) + (test-equal `(*TOP* (*PI* xml "test") + (a)) + tree))))) + + (test-group "namespaced-sxml->sxml" + (test-equal "Without namespaces" + '(*TOP* (a (@))) + (namespaced-sxml->sxml `(*TOP* (,(xml 'a))))) + + (test-group "With namespaces" + (match (namespaced-sxml->sxml `(*TOP* (,(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) #\:)) + (key-pair (string-split (symbol->string key) #\:))) + (test-equal "a" (cadr el-pair)) + (test-equal "xmlns" (car key-pair)) + (test-equal (car el-pair) (cadr key-pair)))) + (any + (test-assert (format #f "Match failed: ~s" any) #f)))))) + +;; (namespaced-sxml->xml) +;; Literal strings + + +(test-error "Namespaces x is missing, note error" + 'parser-error + (xml->namespaced-sxml "" + ; `((x . ,(ns 1))) + )) + +'((sxml namespaced)) diff --git a/tests/unit/sxml/xml-namespace.scm b/tests/unit/sxml/xml-namespace.scm new file mode 100644 index 00000000..2b6ea174 --- /dev/null +++ b/tests/unit/sxml/xml-namespace.scm @@ -0,0 +1,38 @@ +(define-module (test xml-namespace) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((sxml namespace) :select (move-to-namespace))) + +(test-equal + "Move unnamespaced to namespace" + '(NEW:test) + (move-to-namespace '(test) '((#f . NEW)))) + +(test-equal + "Swap namespaces" + '(b:a (a:b)) + (move-to-namespace + '(a:a (b:b)) + '((a . b) (b . a)))) + +(test-equal + "Remove all namespaces" + '(a (b)) + (move-to-namespace '(a:a (b:b)) #f)) + +(test-equal + "Move everything to one namespace" + '(c:a (c:b)) + (move-to-namespace '(a:a (b:b)) 'c)) + +(test-equal + "Partial namespace change" + '(c:a (b:b)) + (move-to-namespace '(a:a (b:b)) '((a . c)))) + +(test-equal + "Remove specific namespace" + '(a:a (b)) + (move-to-namespace '(a:a (b:b)) '((b . #f)))) + +'((sxml namespace)) diff --git a/tests/unit/util/sxml-namespaced.scm b/tests/unit/util/sxml-namespaced.scm deleted file mode 100644 index b2d55028..00000000 --- a/tests/unit/util/sxml-namespaced.scm +++ /dev/null @@ -1,172 +0,0 @@ -(define-module (test sxml-namespaced) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (ice-9 match) - :use-module (sxml namespaced) - :use-module (hnh util state-monad) - ) - -;;; TODO tests with attributes - -(define (ns x) - (string->symbol (format #f "http://example.com/~a" x))) - -(define (namespaced-symbol ns symb) - (string->symbol (format #f "~a:~a" ns symb))) - - - -(test-group "XML constructor utility procedure" - (test-equal "3 args" - (make-xml-element 'tagname 'namespace 'attributes) - (xml 'namespace 'tagname 'attributes)) - - (test-equal "2 args" - (make-xml-element 'tagname 'namespace '()) - (xml 'namespace 'tagname)) - - (test-equal "1 args" - (make-xml-element 'tagname #f '()) - (xml 'tagname))) - - - -(test-group "xml->namespaced-sxml" - - (test-equal - `(*TOP* (,(xml 'tag))) - (xml->namespaced-sxml "")) - - (test-equal - `(*TOP* (,(xml 'ns1 'tag))) - (xml->namespaced-sxml "")) - - (test-equal - `(*TOP* (,(xml 'ns2 'tag))) - (xml->namespaced-sxml "")) - - (test-equal - `(*TOP* (,(xml 'ns2 'tag) - (,(xml 'ns1 'tag)))) - (xml->namespaced-sxml "")) - - (test-equal "PI are passed directly" - `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") - (,(xml 'tag))) - (xml->namespaced-sxml "")) - - (test-equal "Document with whitespace in it" - `(*TOP* ,(make-pi-element 'xml "") - (,(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* ,(make-pi-element 'xml "") - (,(xml 'root))) - (xml->namespaced-sxml " "))) - - - -;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns -;;; attributes, since xml->sxml doesn't have those. -(test-group "sxml->namespaced-sxml" - (test-equal "Simplest" - `(,(xml 'a)) (sxml->namespaced-sxml '(a) '())) - (test-equal "With *TOP*" - `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '())) - (test-equal "Simplest with namespace" - `(,(xml (ns 1) 'a)) - (sxml->namespaced-sxml '(x:a) - `((x . ,(ns 1))))) - (test-equal "With pi" - `(*TOP* ,(make-pi-element 'xml "test") - (,(xml 'a))) - (sxml->namespaced-sxml - `(*TOP* - (*PI* xml "test") - (a)) - '())) - (test-error "With unknown namespace" - 'missing-namespace - (sxml->namespaced-sxml '(x:a) '()))) - - - -(test-group "namespaced-sxml->*" - - ;; /namespaces is the most "primitive" one - (test-group "/namespaces" - (test-group "Without namespaces" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - (,(xml 'a))))) - (lambda (tree namespaces) - (test-equal `(*TOP* (a)) tree) - (test-equal '() namespaces)))) - - (test-group "With namespaces" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - (,(xml (ns 1) 'a) - (,(xml (ns 2) 'a)) - (,(xml 'a)))))) - (lambda (tree nss) - (test-eqv 2 (length nss)) - (test-equal - `(*TOP* - (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a) - (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a)) - (a))) - tree)))) - - (test-group "*PI*" - (call-with-values - (lambda () - (namespaced-sxml->sxml/namespaces - `(*TOP* - ,(make-pi-element 'xml "test") - (,(xml 'a))))) - (lambda (tree namespaces) - (test-equal '() namespaces) - (test-equal `(*TOP* (*PI* xml "test") - (a)) - tree))))) - - (test-group "namespaced-sxml->sxml" - (test-equal "Without namespaces" - '(*TOP* (a (@))) - (namespaced-sxml->sxml `(*TOP* (,(xml 'a))))) - - (test-group "With namespaces" - (match (namespaced-sxml->sxml `(*TOP* (,(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) #\:)) - (key-pair (string-split (symbol->string key) #\:))) - (test-equal "a" (cadr el-pair)) - (test-equal "xmlns" (car key-pair)) - (test-equal (car el-pair) (cadr key-pair)))) - (any - (test-assert (format #f "Match failed: ~s" any) #f)))))) - -;; (namespaced-sxml->xml) -;; Literal strings - - -(test-error "Namespaces x is missing, note error" - 'parser-error - (xml->namespaced-sxml "" - ; `((x . ,(ns 1))) - )) - -'((sxml namespaced)) diff --git a/tests/unit/util/xml-namespace.scm b/tests/unit/util/xml-namespace.scm deleted file mode 100644 index 2b6ea174..00000000 --- a/tests/unit/util/xml-namespace.scm +++ /dev/null @@ -1,38 +0,0 @@ -(define-module (test xml-namespace) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((sxml namespace) :select (move-to-namespace))) - -(test-equal - "Move unnamespaced to namespace" - '(NEW:test) - (move-to-namespace '(test) '((#f . NEW)))) - -(test-equal - "Swap namespaces" - '(b:a (a:b)) - (move-to-namespace - '(a:a (b:b)) - '((a . b) (b . a)))) - -(test-equal - "Remove all namespaces" - '(a (b)) - (move-to-namespace '(a:a (b:b)) #f)) - -(test-equal - "Move everything to one namespace" - '(c:a (c:b)) - (move-to-namespace '(a:a (b:b)) 'c)) - -(test-equal - "Partial namespace change" - '(c:a (b:b)) - (move-to-namespace '(a:a (b:b)) '((a . c)))) - -(test-equal - "Remove specific namespace" - '(a:a (b)) - (move-to-namespace '(a:a (b:b)) '((b . #f)))) - -'((sxml namespace)) -- cgit v1.2.3