diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-10-18 20:24:48 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-10-18 20:24:48 +0200 |
commit | 53a829e90f84728e8ce5c3bba58ce3449cdb073c (patch) | |
tree | 57e488bdd6c59363558764dcc7ea7a4505ddc8f9 | |
parent | Fix spelling. (diff) | |
download | calp-53a829e90f84728e8ce5c3bba58ce3449cdb073c.tar.gz calp-53a829e90f84728e8ce5c3bba58ce3449cdb073c.tar.xz |
Change namespaced sxml to use new object system.
-rw-r--r-- | module/sxml/namespaced.scm | 53 | ||||
-rw-r--r-- | tests/unit/sxml/sxml-namespaced.scm | 18 |
2 files changed, 37 insertions, 34 deletions
diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm index e5a334da..9fbcdf08 100644 --- a/module/sxml/namespaced.scm +++ b/module/sxml/namespaced.scm @@ -3,12 +3,12 @@ :use-module (sxml util) :use-module (ice-9 match) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-71) :use-module (srfi srfi-88) :use-module (hnh util state-monad) :use-module ((hnh util io) :select (->port)) + :use-module (hnh util object) + :use-module (hnh util type) :export (xml->namespaced-sxml namespaced-sxml->xml namespaced-sxml->sxml @@ -17,13 +17,13 @@ xml attribute - make-xml-element + xml-element xml-element? xml-element-tagname xml-element-namespace xml-element-attributes - make-pi-element + pi-element pi-element? pi-tag pi-body @@ -34,26 +34,29 @@ ;; (make-pi-element 'xml "version=\"1.0\" encoding=\"utf-8\"") ;; tag should always be a symbol ;; body should always be a string -(define-record-type <pi-element> - (make-pi-element tag body) - pi-element? - (tag pi-tag) - (body pi-body)) - - -(define-record-type <xml-element> - (make-xml-element tagname namespace attributes) - xml-element? - (tagname xml-element-tagname) - (namespace xml-element-namespace) - (attributes xml-element-attributes)) - +(define-type (pi-element + constructor: (lambda (constructor typecheck) + (lambda (tag body) + (typecheck tag body) + (constructor tag body)))) + (pi-tag type: symbol?) + (pi-body type: string?)) + +(define-type (xml-element) + (xml-element-tagname type: symbol? + keyword: tag) + (xml-element-namespace type: (or false? symbol?) + default: #f + keyword: ns) + (xml-element-attributes type: (list-of (pair-of symbol? string?)) + default: '() + keyword: attributes)) (define xml (case-lambda - ((tag) (make-xml-element tag #f '())) - ((ns tag) (make-xml-element tag ns '())) - ((ns tag attrs) (make-xml-element tag ns attrs)))) + ((tag) (xml-element tag: tag)) + ((ns tag) (xml-element tag: tag ns: ns)) + ((ns tag attrs) (xml-element tag: tag ns: ns attributes: attrs)))) (define (attribute xml attr) (assoc-ref (xml-element-attributes xml) attr)) @@ -84,8 +87,8 @@ (cons (list (match elem-gi - ((ns . tag) (make-xml-element tag ns attributes)) - (tag (make-xml-element tag #f attributes)))) + ((ns . tag) (xml-element tag: tag ns: ns attributes: attributes)) + (tag (xml-element tag: tag attributes: attributes)))) seed)) FINISH-ELEMENT @@ -114,7 +117,7 @@ (let ((body (ssax:read-pi-body-as-string port))) (match seed (((parent . children) . rest) - `((,parent ,(make-pi-element pi-tag body) ,@children) + `((,parent ,(pi-element pi-tag body) ,@children) ,@rest))))))) )) @@ -245,7 +248,7 @@ ;; Returns a namespaced sxml tree (define (sxml->namespaced-sxml tree namespaces) (match tree - (('*PI* tag body) (make-pi-element tag body)) + (('*PI* tag body) (pi-element tag body)) (('*TOP* rest ...) `(*TOP* ,@(map (lambda (r) (sxml->namespaced-sxml r namespaces)) rest))) diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm index b2d55028..52f86303 100644 --- a/tests/unit/sxml/sxml-namespaced.scm +++ b/tests/unit/sxml/sxml-namespaced.scm @@ -19,15 +19,15 @@ (test-group "XML constructor utility procedure" (test-equal "3 args" - (make-xml-element 'tagname 'namespace 'attributes) - (xml 'namespace 'tagname 'attributes)) + (xml-element tag: 'tagname ns: 'namespace attributes: '()) + (xml 'namespace 'tagname '())) (test-equal "2 args" - (make-xml-element 'tagname 'namespace '()) + (xml-element tag: 'tagname ns: 'namespace attributes: '()) (xml 'namespace 'tagname)) (test-equal "1 args" - (make-xml-element 'tagname #f '()) + (xml-element tag: 'tagname attributes: '()) (xml 'tagname))) @@ -52,12 +52,12 @@ (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>")) (test-equal "PI are passed directly" - `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") + `(*TOP* ,(pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") (,(xml 'tag))) (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>")) (test-equal "Document with whitespace in it" - `(*TOP* ,(make-pi-element 'xml "") + `(*TOP* ,(pi-element 'xml "") (,(xml 'root) " " (,(xml 'a)) @@ -67,7 +67,7 @@ ;; TODO is this expected? xml->sxml discards it. (test-equal "Whitespace before root is kept" - `(*TOP* ,(make-pi-element 'xml "") + `(*TOP* ,(pi-element 'xml "") (,(xml 'root))) (xml->namespaced-sxml "<?xml?> <root/>"))) @@ -85,7 +85,7 @@ (sxml->namespaced-sxml '(x:a) `((x . ,(ns 1))))) (test-equal "With pi" - `(*TOP* ,(make-pi-element 'xml "test") + `(*TOP* ,(pi-element 'xml "test") (,(xml 'a))) (sxml->namespaced-sxml `(*TOP* @@ -134,7 +134,7 @@ (lambda () (namespaced-sxml->sxml/namespaces `(*TOP* - ,(make-pi-element 'xml "test") + ,(pi-element 'xml "test") (,(xml 'a))))) (lambda (tree namespaces) (test-equal '() namespaces) |