From 390c026d85ee89a7bc9284f517f3ca6bcbd48fb0 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 19 Jul 2004 17:36:48 +0000 Subject: [PATCH] Move generic XML convenience procedures from "xhtml.scm" to "xml-struct.scm". Add new procedures STANDARD-XML-ELEMENT-CONSTRUCTOR and STANDARD-XML-ELEMENT-PREDICATE. --- v7/src/xml/xhtml.scm | 101 ++++---------------------------------- v7/src/xml/xml-struct.scm | 95 +++++++++++++++++++++++++++++++++-- v7/src/xml/xml.pkg | 9 ++-- 3 files changed, 106 insertions(+), 99 deletions(-) diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm index bb701a268..04973afcf 100644 --- a/v7/src/xml/xhtml.scm +++ b/v7/src/xml/xhtml.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xhtml.scm,v 1.6 2004/07/19 04:45:11 cph Exp $ +$Id: xhtml.scm,v 1.7 2004/07/19 17:36:28 cph Exp $ Copyright 2002,2003,2004 Massachusetts Institute of Technology @@ -63,28 +63,17 @@ USA. (empty? (pair? (cdddr form)))) `(BEGIN (DEFINE ,(symbol-append 'HTML: name) - (STANDARD-HTML-CONSTRUCTOR ',name ',context ,empty?)) + (STANDARD-XML-ELEMENT-CONSTRUCTOR ',name HTML-IRI ,empty?)) (DEFINE ,(symbol-append 'HTML: name '?) - (STANDARD-HTML-PREDICATE ',name)) - ',name)) + (STANDARD-XML-ELEMENT-PREDICATE ',name HTML-IRI)) + (DEFINE-HTML-ELEMENT-CONTEXT ',name ',context))) (ill-formed-syntax form))))) -(define (standard-html-constructor simple context empty?) - (let ((name (make-xml-name simple html-iri))) - (hash-table/put! element-context-map name context) - (if empty? - (lambda items - (make-xml-element name (apply xml-attrs items) '())) - (lambda (attrs . items) - (make-xml-element name - (if (not attrs) '() attrs) - (flatten-xml-element-contents items)))))) - -(define (standard-html-predicate simple) - (let ((name (make-xml-name simple html-iri))) - (lambda (object) - (and (xml-element? object) - (xml-name=? (xml-element-name object) name))))) +(define (define-html-element-context qname context) + (hash-table/put! element-context-map + (make-xml-name qname html-iri) + context) + qname) (define (html-element-context elt) (guarantee-html-element elt 'HTML-ELEMENT-CONTEXT) @@ -100,78 +89,6 @@ USA. (define element-context-map (make-eq-hash-table)) -(define (xml-attrs . items) - (let loop ((items items)) - (if (pair? items) - (let ((item (car items)) - (items (cdr items))) - (cond ((and (xml-name? item) - (pair? items)) - (let ((value (car items)) - (attrs (loop (cdr items)))) - (if value - (cons (make-xml-attribute - item - (if (eq? value #t) - (symbol-name item) - (convert-xml-string-value value))) - attrs) - attrs))) - ((xml-attribute? item) - (cons item (loop items))) - ((list-of-type? item xml-attribute?) - (append item (loop items))) - (else - (error "Unknown item passed to xml-attrs:" item)))) - '()))) - -(define (flatten-xml-element-contents item) - (letrec - ((scan-item - (lambda (item tail) - (cond ((pair? item) (scan-list item tail)) - ((or (not item) (null? item)) tail) - (else (cons (convert-xml-string-value item) tail))))) - (scan-list - (lambda (items tail) - (if (pair? items) - (scan-item (car items) - (scan-list (cdr items) tail)) - (begin - (if (not (null? items)) - (error:wrong-type-datum items "list")) - tail))))) - (scan-item item '()))) - -(define (convert-xml-string-value value) - (cond ((xml-content-item? value) value) - ((symbol? value) (symbol-name value)) - ((number? value) (number->string value)) - ((xml-namespace-iri? value) (xml-namespace-iri-string value)) - ((list-of-type? value xml-nmtoken?) (nmtokens->string value)) - (else (error:wrong-type-datum value "string value")))) - -(define (nmtokens->string nmtokens) - (if (pair? nmtokens) - (let ((nmtoken-length - (lambda (nmtoken) - (string-length (symbol-name nmtoken))))) - (let ((s - (make-string - (let loop ((nmtokens nmtokens) (n 0)) - (let ((n (fix:+ n (nmtoken-length (car nmtokens))))) - (if (pair? (cdr nmtokens)) - (loop (cdr nmtokens) (fix:+ n 1)) - n)))))) - (let loop ((nmtokens nmtokens) (index 0)) - (string-move! (symbol-name (car nmtokens)) s index) - (if (pair? (cdr nmtokens)) - (let ((index (fix:+ index (nmtoken-length (car nmtokens))))) - (string-set! s index #\space) - (loop (cdr nmtokens) (fix:+ index 1))))) - s)) - (make-string 0))) - (define-html-element a inline) (define-html-element abbr inline) (define-html-element acronym inline) diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm index 20ebaa6c6..eb77c770a 100644 --- a/v7/src/xml/xml-struct.scm +++ b/v7/src/xml/xml-struct.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml-struct.scm,v 1.43 2004/07/19 04:45:20 cph Exp $ +$Id: xml-struct.scm,v 1.44 2004/07/19 17:36:48 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -453,8 +453,9 @@ USA. (if (xml-name=? name 'xmlns) (null-xml-name-prefix) (xml-name-local name))))))) + +;;;; Convenience procedures -;; Convenience procedure (define (xml-comment . strings) (make-xml-comment (let* ((s (apply string-append (map canonicalize-char-data strings))) @@ -465,4 +466,92 @@ USA. (if (char-whitespace? (wide-string-ref ws 0)) "" " ") s (if (char-whitespace? (wide-string-ref ws (fix:- n 1))) "" " ")) - " ")))) \ No newline at end of file + " ")))) + +(define (standard-xml-element-constructor qname iri empty?) + (let ((name (make-xml-name qname iri))) + (if empty? + (lambda items + (make-xml-element name (apply xml-attrs items) '())) + (lambda (attrs . items) + (make-xml-element name + (if (not attrs) '() attrs) + (flatten-xml-element-contents items)))))) + +(define (standard-xml-element-predicate qname iri) + (let ((name (make-xml-name qname iri))) + (lambda (object) + (and (xml-element? object) + (xml-name=? (xml-element-name object) name))))) + +(define (xml-attrs . items) + (let loop ((items items)) + (if (pair? items) + (let ((item (car items)) + (items (cdr items))) + (cond ((and (xml-name? item) + (pair? items)) + (let ((value (car items)) + (attrs (loop (cdr items)))) + (if value + (cons (make-xml-attribute + item + (if (eq? value #t) + (symbol-name item) + (convert-xml-string-value value))) + attrs) + attrs))) + ((xml-attribute? item) + (cons item (loop items))) + ((list-of-type? item xml-attribute?) + (append item (loop items))) + (else + (error "Unknown item passed to xml-attrs:" item)))) + '()))) + +(define (flatten-xml-element-contents item) + (letrec + ((scan-item + (lambda (item tail) + (cond ((pair? item) (scan-list item tail)) + ((or (not item) (null? item)) tail) + (else (cons (convert-xml-string-value item) tail))))) + (scan-list + (lambda (items tail) + (if (pair? items) + (scan-item (car items) + (scan-list (cdr items) tail)) + (begin + (if (not (null? items)) + (error:wrong-type-datum items "list")) + tail))))) + (scan-item item '()))) + +(define (convert-xml-string-value value) + (cond ((xml-content-item? value) value) + ((symbol? value) (symbol-name value)) + ((number? value) (number->string value)) + ((xml-namespace-iri? value) (xml-namespace-iri-string value)) + ((list-of-type? value xml-nmtoken?) (nmtokens->string value)) + (else (error:wrong-type-datum value "string value")))) + +(define (nmtokens->string nmtokens) + (if (pair? nmtokens) + (let ((nmtoken-length + (lambda (nmtoken) + (string-length (symbol-name nmtoken))))) + (let ((s + (make-string + (let loop ((nmtokens nmtokens) (n 0)) + (let ((n (fix:+ n (nmtoken-length (car nmtokens))))) + (if (pair? (cdr nmtokens)) + (loop (cdr nmtokens) (fix:+ n 1)) + n)))))) + (let loop ((nmtokens nmtokens) (index 0)) + (string-move! (symbol-name (car nmtokens)) s index) + (if (pair? (cdr nmtokens)) + (let ((index (fix:+ index (nmtoken-length (car nmtokens))))) + (string-set! s index #\space) + (loop (cdr nmtokens) (fix:+ index 1))))) + s)) + (make-string 0))) \ No newline at end of file diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 94718c291..d48510333 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.46 2004/07/19 17:20:40 cph Exp $ +$Id: xml.pkg,v 1.47 2004/07/19 17:36:35 cph Exp $ Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology @@ -188,6 +188,8 @@ USA. set-xml-unparsed-!entity-id! set-xml-unparsed-!entity-name! set-xml-unparsed-!entity-notation! + standard-xml-element-constructor + standard-xml-element-predicate xml-!attlist-definitions xml-!attlist-name xml-!attlist? @@ -205,6 +207,7 @@ USA. xml-attribute-namespace-decl? xml-attribute-value xml-attribute? + xml-attrs xml-char-data? xml-comment xml-comment-text @@ -298,7 +301,6 @@ USA. (files "xhtml") (parent (runtime xml)) (export () - flatten-xml-element-contents guarantee-html-element guarantee-html-element-name html-dtd @@ -469,5 +471,4 @@ USA. html:ul html:ul? html:var - html:var? - xml-attrs)) \ No newline at end of file + html:var?)) \ No newline at end of file -- 2.25.1