diff options
Diffstat (limited to '')
-rw-r--r-- | module/sxml/namespaced.scm | 266 | ||||
-rw-r--r-- | module/sxml/namespaced/util.scm | 45 | ||||
-rw-r--r-- | module/sxml/util.scm | 22 |
3 files changed, 333 insertions, 0 deletions
diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm new file mode 100644 index 00000000..e5a334da --- /dev/null +++ b/module/sxml/namespaced.scm @@ -0,0 +1,266 @@ +(define-module (sxml namespaced) + :use-module (sxml ssax) + :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)) + :export (xml->namespaced-sxml + namespaced-sxml->xml + namespaced-sxml->sxml + namespaced-sxml->sxml/namespaces + sxml->namespaced-sxml + xml + attribute + + make-xml-element + xml-element? + xml-element-tagname + xml-element-namespace + xml-element-attributes + + make-pi-element + pi-element? + pi-tag + pi-body + )) + +;; XML processing instruction elements (and other things with identical syntax) +;; For example: <?xml version="1.0" encoding="utf-8"?> would be encoded as +;; (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 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)))) + +(define (attribute xml attr) + (assoc-ref (xml-element-attributes xml) attr)) + + +(define* (parser key: trim-whitespace?) + (ssax:make-parser + + ;; DOCTYPE + ;; (lambda (port docname systemid internal-subset? seed) + ;; (format (current-error-port) + ;; "doctype: port=~s, docname=~s, systemid=~s, internal-subset?=~s, seed=~s~%" + ;; port docname systemid internal-subset? seed) + ;; (values #f '() '() seed)) + + ;; UNDECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Undecl-root: ~s~%" elem-gi) + ;; (values #f '() '() seed)) + + ;; DECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Decl-root: ~s~%" elem-gi) + ;; seed) + + NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content seed) + (cons + (list + (match elem-gi + ((ns . tag) (make-xml-element tag ns attributes)) + (tag (make-xml-element tag #f attributes)))) + seed)) + + FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed seed) + (match seed + (((self . self-children) (parent . children) . rest) + `((,parent (,self ,@(reverse self-children)) ,@children) + ,@rest)))) + + CHAR-DATA-HANDLER + (lambda (str1 str2 seed) + (define s + (if trim-whitespace? + (string-trim-both (string-append str1 str2)) + (string-append str1 str2))) + (cond ((string-null? s) seed) + (else + (match seed + (((parent . children) . rest) + `((,parent ,(string-append str1 str2) + ,@children) + ,@rest)))))) + + PI + ((*DEFAULT* . (lambda (port pi-tag seed) + (let ((body (ssax:read-pi-body-as-string port))) + (match seed + (((parent . children) . rest) + `((,parent ,(make-pi-element pi-tag body) ,@children) + ,@rest))))))) + )) + + +(define* (xml->namespaced-sxml port-or-string key: (trim-whitespace? #t)) + (match (with-ssax-error-to-port + (current-error-port) + (lambda () ((parser trim-whitespace?: trim-whitespace?) + (->port port-or-string) + '((*TOP*))))) + ((('*TOP* . items)) + `(*TOP* ,@(reverse items))))) + +(define (pi-element->sxml pi) + `(*PI* ,(pi-tag pi) ,(pi-body pi))) + + + +(define (ns-pair->attribute pair) + (let ((fqdn short (car+cdr pair))) + (list (string->symbol (format #f "xmlns:~a" short)) + (symbol->string fqdn)))) + +;; Takes an association list from full namespace names (as symbols), to their +;; short forms, and returns a list containing xmlns:x-attributes suitable for +;; splicing into scheme's "regular" sxml. +(define (ns-alist->attributes ns) + (map ns-pair->attribute ns)) + + + +(define (get-prefix ns) + (do namespaces <- (get) + (cond ((assq-ref namespaces ns) => return) + (else (do prefix = (gensym "ns") + (put (acons ns prefix namespaces)) + (return prefix)))))) + + +(define (xml-element->sxml el) + (do tag <- (cond ((xml-element-namespace el) + => (lambda (ns) + (do pre <- (get-prefix ns) + (return + (string->symbol + (format #f "~a:~a" pre (xml-element-tagname el))))))) + (else (return (xml-element-tagname el)))) + (return + (lambda (children) + (cond ((null? (xml-element-attributes el)) + `(,tag ,@children)) + (else + `(,tag (@ ,@(map (lambda (p) + (call-with-values (lambda () (car+cdr p)) list)) + (xml-element-attributes el))) + ,@children))))))) + +(define (sxml->xml-element el namespaces) + (lambda (children) + (let ((tag-symb attrs + (match el + ((tag ('@ attrs ...)) + (values tag (map (lambda (p) (apply cons p)) attrs))) + ((tag) (values tag '()))))) + (let ((parts (string-split (symbol->string tag-symb) #\:))) + (cons (case (length parts) + ((1) (xml (assoc-ref namespaces #f) + (string->symbol (car parts)) attrs)) + ((2) + (cond ((assoc-ref namespaces (string->symbol (car parts))) + => (lambda (ns) (xml ns (string->symbol (cadr parts)) attrs))) + (else (scm-error 'missing-namespace "sxml->xml-element" + "Unknown namespace prefix encountered: ~s (on tag ~s)" + (list (car parts) (cadr parts)) + #f)))) + (else (scm-error 'misc-error "sxml->xml-element" + "Invalid QName: more than one colon ~s" + (list tag-symb) #f))) + children))))) + + +(define (namespaced-sxml->sxml* tree) + (cond ((null? tree) (return tree)) + ((string? tree) (return tree)) + ((pi-element? tree) (return (pi-element->sxml tree))) + ((not (pair? tree)) (return tree)) + ((car tree) symbol? + => (lambda (symb) + (case symb + ((*TOP*) (do children <- (sequence (map namespaced-sxml->sxml* + (cdr tree))) + + (return (cons '*TOP* children)))) + (else (return tree))))) + ((xml-element? (car tree)) + (do proc <- (xml-element->sxml (car tree)) + children <- (sequence (map namespaced-sxml->sxml* (cdr tree))) + (return (proc children)))) + + ;; list of xml-element? + (else (scm-error 'misc-error "namespaced-sxml->sxml*" + "Unexpected token in tree: ~s" + (list tree) + #f)))) + + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns a sxml tree, with xmlns:<prefix>=namespace attributes +(define* (namespaced-sxml->sxml tree optional: (namespace-prefixes '())) + (let ((tree ns ((namespaced-sxml->sxml* tree) namespace-prefixes))) + ((get-root-element tree) + (lambda (root) + (add-attributes root (ns-alist->attributes ns)))))) + +(define* (namespaced-sxml->xml tree key: + (namespaces '()) + (port (current-output-port))) + ((@ (sxml simple) sxml->xml) + (namespaced-sxml->sxml tree namespaces) port)) + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns two values: a sxml tree without declared namespaces +;; and a association list from namespace symbols, to used prefixes +(define* (namespaced-sxml->sxml/namespaces tree optional: (namespace-prefixes '())) + ((namespaced-sxml->sxml* tree) namespace-prefixes)) + +;; Takes an sxml tree, and an association list from prefixes to namespaces +;; Returns a namespaced sxml tree +(define (sxml->namespaced-sxml tree namespaces) + (match tree + (('*PI* tag body) (make-pi-element tag body)) + (('*TOP* rest ...) + `(*TOP* ,@(map (lambda (r) (sxml->namespaced-sxml r namespaces)) + rest))) + ((el ('@ attrs ...) rest ...) + ((sxml->xml-element `(,el (@ ,@attrs)) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + ((el rest ...) + ((sxml->xml-element `(,el) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + (atom atom))) + +;;; TODO read intro-comment in SSAX file +;;; 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) + diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm new file mode 100644 index 00000000..6f93e362 --- /dev/null +++ b/module/sxml/namespaced/util.scm @@ -0,0 +1,45 @@ +(define-module (sxml namespaced util) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module ((ice-9 control) :select (call/ec)) + :export (xml-element-hash-key + find-element + element-matches? + on-root-element + root-element + )) + +(define (xml-element-hash-key tag) + "Returns a value suitable as a key to hash-ref (and family)" + (cons (xml-element-namespace tag) + (xml-element-tagname tag))) + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + + +(define (element-matches? target-el tree) + (and (not (null? tree)) + (equal? + (xml-element-hash-key target-el) + (xml-element-hash-key (car tree))))) + + +(define (on-root-element proc tree) + (cond ((and (eq? '*TOP* (car tree)) + (pi-element? (cadr tree))) + (cons* (car tree) (cadr tree) + (proc (caddr tree)))) + ((eq? '*TOP* (car tree)) + (cons (car tree) + (proc (cadr tree)))) + (else (proc (car tree))))) + +(define (root-element tree) + (call/ec (lambda (return) + (on-root-element return tree)))) diff --git a/module/sxml/util.scm b/module/sxml/util.scm new file mode 100644 index 00000000..532141b2 --- /dev/null +++ b/module/sxml/util.scm @@ -0,0 +1,22 @@ +(define-module (sxml util) + :use-module (ice-9 match) + :export (get-root-element add-attributes)) + +(define (get-root-element tree) + (match tree + (('*TOP* ('*PI* 'xml body) (root . children)) + (lambda (modifier) `(*TOP* (*PI* xml ,body) + ,(modifier `(,root ,@children))))) + (('*TOP* (root . children)) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))) + ((root . children) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))))) + +(define (add-attributes element added-attributes) + (match element + ((el ('@ . attributes) . children) + `(,el (@ ,@attributes ,@added-attributes) + ,@children)) + ((el . children) + `(,el (@ ,@added-attributes) + ,@children)))) |