diff options
Diffstat (limited to 'module/sxml/namespaced.scm')
| -rw-r--r-- | module/sxml/namespaced.scm | 44 |
1 files changed, 27 insertions, 17 deletions
diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm index 1c2eb322..82a137c5 100644 --- a/module/sxml/namespaced.scm +++ b/module/sxml/namespaced.scm @@ -24,6 +24,7 @@ xml-element xml-element? + xml-element*? xml-element-tagname xml-element-namespace xml-element-attributes @@ -39,6 +40,7 @@ pi-body )) + (define (car+cadr p) (values (car p) (cadr p))) (define (2list->pair l) (call-with-values (lambda () (car+cadr l)) cons)) @@ -66,14 +68,16 @@ ns: ,(xml-element-namespace el) attributes: ,(serialize-table (xml-element-attributes el)) children: (list ,@(map (lambda (e) - (cond ((xml-element? e) + (cond ((xml-element*? e) (serialize-xml-element e)) (else e))) (xml-element-children el))))) -(define-type (xml-element printer: (lambda (r p) - (pretty-print (serialize-xml-element r) - p))) + +(define-type (xml-element + printer: (lambda (r p) + (pretty-print (serialize-xml-element r) + p))) (xml-element-tagname type: symbol? keyword: tag) (xml-element-namespace type: (or false? symbol?) @@ -91,8 +95,15 @@ default: '())) +;;; NOTE Due to how define-type works, and how guile expands forms, +;;; this MUST be placed after the xml-element declaration. Otherwise +;;; `xml-element?' is of type syntax-transformer, which isn't a procedure. +(define (xml-element*? x) + (xml-element? x)) + + (define-type (xml-document) - (xml-document-root type: xml-element? + (xml-document-root type: xml-element*? keyword: root) (xml-document-pis type: (list-of pi-element?) keyword: pi @@ -104,7 +115,7 @@ ((tag) (lambda children (xml-element children: children tag: tag))) ((ns tag) (lambda children (xml-element children: children tag: tag ns: ns))) ((ns tag attrs) (lambda children (xml-element children: children tag: tag ns: ns - attributes: (attributes->table attrs)))))) + attributes: (attributes->table attrs)))))) (define (attribute xml attr) (assoc-ref (xml-element-attributes xml) attr)) @@ -162,7 +173,7 @@ (lambda (elem-gi attributes namespaces parent-seed seed) (let ((head tail (pop seed))) (modify tail - (find* xml-element?) + (find* xml-element*?) (lambda (parent) (add-child (modify head xml-element-children* reverse) @@ -174,9 +185,9 @@ (if trim-whitespace? (string-trim-both (string-append s1 s2)) (string-append s1 s2))) - (if (null? s) + (if (string-null? s) seed - (modify seed (lens-compose (find* xml-element?) + (modify seed (lens-compose (find* xml-element*?) xml-element-children*) (lambda (ch) (cons s ch))))) @@ -185,7 +196,7 @@ ((*DEFAULT* . (lambda (port pi-tag seed) (let ((body (ssax:read-pi-body-as-string port))) (modify seed - (find* xml-element?) + (find* xml-element*?) (lambda (parent) (add-child (pi-element pi-tag body) parent))))))))) @@ -196,11 +207,11 @@ (with-ssax-error-to-port (current-error-port) (lambda () ((parser trim-whitespace?: trim-whitespace?) - (->port port-or-string) - (list ((xml 'ROOT))))))) + (->port port-or-string) + (list ((xml 'ROOT))))))) (let ((roots pis - (partition xml-element? + (partition xml-element*? (-> result peek xml-element-children)))) (xml-document root: (car roots) @@ -277,13 +288,13 @@ (define (namespaced-sxml->sxml* tree) (cond ((string? tree) (return tree)) - ((xml-element? tree) (xml-element->sxml tree)) + ((xml-element*? tree) (xml-element->sxml tree)) ((pi-element? tree) (return (pi-element->sxml tree))) ((xml-document? tree) (do pis <- (sequence (map namespaced-sxml->sxml* (xml-document-pis tree))) el <- (namespaced-sxml->sxml* - (xml-document-root tree)) + (xml-document-root tree)) (return `(*TOP* ,@pis ,el)))) (else (scm-error 'misc-error "namespaced-sxml->sxml*" "Unexpected token in tree: ~s" @@ -326,7 +337,7 @@ (('*TOP* rest ...) (let ((groups (group-by (lambda (x) - (cond ((xml-element? x) 'el) + (cond ((xml-element*? x) 'el) ((pi-element? x) 'pi) (else #f))) (map (lambda (r) (sxml->namespaced-sxml r namespaces)) @@ -362,4 +373,3 @@ ;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these ;;; new trees (probably rewriting to a "regular" sxml tree, and keeping ;;; a strict mapping of namespaces) - |