From 1d61ef3a459bcd97bdcad71eddd77ec1db9cf363 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 19 Jul 2004 04:45:20 +0000 Subject: [PATCH] Update list of element names to cover exactly those elements defined by XHTML 1.0 strict, and no others. Add some context information, for use in styling and analysis. New procedures GUARANTEE-HTML-ELEMENT, HTML-ELEMENT-NAME?, GUARANTEE-HTML-ELEMENT-NAME, HTML-ELEMENT-CONTEXT, HTML-ELEMENT-NAME-CONTEXT, HTML-ELEMENT-NAMES. Rename HTML-ATTRS to XML-ATTRS. Rename HTML:COMMENT to XML-COMMENT and move it to "xml-struct". --- v7/src/xml/xhtml.scm | 292 +++++++++++++++++++------------------- v7/src/xml/xml-struct.scm | 17 ++- v7/src/xml/xml.pkg | 58 +++++--- 3 files changed, 201 insertions(+), 166 deletions(-) diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm index a2f3921ad..bb701a268 100644 --- a/v7/src/xml/xhtml.scm +++ b/v7/src/xml/xhtml.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xhtml.scm,v 1.5 2004/07/18 04:34:00 cph Exp $ +$Id: xhtml.scm,v 1.6 2004/07/19 04:45:11 cph Exp $ Copyright 2002,2003,2004 Massachusetts Institute of Technology @@ -41,144 +41,66 @@ USA. (and (xml-element? object) (xml-name-iri=? (xml-element-name object) html-iri))) -(define-syntax define-standard-element +(define (guarantee-html-element object caller) + (if (not (html-element? object)) + (error:wrong-type-argument object "XHTML element" caller))) + +(define (html-element-name? object) + (and (xml-name? object) + (xml-name-iri=? object html-iri))) + +(define (guarantee-html-element-name object caller) + (if (not (html-element-name? object)) + (error:wrong-type-argument object "XHTML element name" caller))) + +(define-syntax define-html-element (sc-macro-transformer (lambda (form environment) environment - (if (syntax-match? '(IDENTIFIER) (cdr form)) - (let ((name (cadr form))) + (if (syntax-match? '(SYMBOL SYMBOL ? 'EMPTY) (cdr form)) + (let ((name (cadr form)) + (context (caddr form)) + (empty? (pair? (cdddr form)))) `(BEGIN (DEFINE ,(symbol-append 'HTML: name) - (STANDARD-ELEMENT-CONSTRUCTOR ',name HTML-IRI)) + (STANDARD-HTML-CONSTRUCTOR ',name ',context ,empty?)) (DEFINE ,(symbol-append 'HTML: name '?) - (STANDARD-ELEMENT-PREDICATE ',name HTML-IRI)))) + (STANDARD-HTML-PREDICATE ',name)) + ',name)) (ill-formed-syntax form))))) -(define (standard-element-constructor simple iri) - (let ((name (make-xml-name simple iri))) - (lambda (attrs . items) - (make-xml-element name - (if (not attrs) - '() - attrs) - (flatten-xml-element-contents items))))) +(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-element-predicate simple iri) - (let ((name (make-xml-name simple iri))) +(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 (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-html-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-standard-element a) -(define-standard-element abbr) -(define-standard-element acronym) -(define-standard-element address) -(define-standard-element b) -(define-standard-element big) -(define-standard-element blockquote) -(define-standard-element body) -(define-standard-element button) -(define-standard-element caption) -(define-standard-element cite) -(define-standard-element code) -(define-standard-element col) -(define-standard-element colgroup) -(define-standard-element dd) -(define-standard-element defn) -(define-standard-element del) -(define-standard-element dir) -(define-standard-element div) -(define-standard-element dl) -(define-standard-element dt) -(define-standard-element em) -(define-standard-element form) -(define-standard-element h1) -(define-standard-element h2) -(define-standard-element h3) -(define-standard-element h4) -(define-standard-element h5) -(define-standard-element head) -(define-standard-element html) -(define-standard-element i) -(define-standard-element ins) -(define-standard-element kbd) -(define-standard-element li) -(define-standard-element listing) -(define-standard-element menu) -(define-standard-element ol) -(define-standard-element optgroup) -(define-standard-element option) -(define-standard-element p) -(define-standard-element pre) -(define-standard-element q) -(define-standard-element s) -(define-standard-element samp) -(define-standard-element script) -(define-standard-element select) -(define-standard-element small) -(define-standard-element span) -(define-standard-element strike) -(define-standard-element strong) -(define-standard-element sub) -(define-standard-element sup) -(define-standard-element table) -(define-standard-element tbody) -(define-standard-element td) -(define-standard-element textarea) -(define-standard-element tfoot) -(define-standard-element th) -(define-standard-element thead) -(define-standard-element title) -(define-standard-element tr) -(define-standard-element tt) -(define-standard-element u) -(define-standard-element ul) -(define-standard-element var) - -(define-syntax define-empty-element - (sc-macro-transformer - (lambda (form environment) - environment - (if (syntax-match? '(IDENTIFIER) (cdr form)) - (let ((name (cadr form))) - `(BEGIN - (DEFINE ,(symbol-append 'HTML: name) - (EMPTY-ELEMENT-CONSTRUCTOR ',name HTML-IRI)) - (DEFINE ,(symbol-append 'HTML: name '?) - (STANDARD-ELEMENT-PREDICATE ',name HTML-IRI)))) - (ill-formed-syntax form))))) +(define (html-element-context elt) + (guarantee-html-element elt 'HTML-ELEMENT-CONTEXT) + (hash-table/get element-context-map (xml-element-name elt) #f)) -(define (empty-element-constructor simple iri) - (let ((name (make-xml-name simple iri))) - (lambda items - (make-xml-element name (apply html-attrs items) '())))) +(define (html-element-name-context name) + (guarantee-html-element-name name 'HTML-ELEMENT-NAME-CONTEXT) + (hash-table/get element-context-map name #f)) -(define-empty-element br) -(define-empty-element hr) -(define-empty-element img) -(define-empty-element input) -(define-empty-element link) -(define-empty-element meta) +(define (html-element-names) + (hash-table/key-list element-context-map)) -(define (html-attrs . items) +(define element-context-map + (make-eq-hash-table)) + +(define (xml-attrs . items) (let loop ((items items)) (if (pair? items) (let ((item (car items)) @@ -192,7 +114,7 @@ USA. item (if (eq? value #t) (symbol-name item) - (convert-html-string-value value))) + (convert-xml-string-value value))) attrs) attrs))) ((xml-attribute? item) @@ -200,10 +122,28 @@ USA. ((list-of-type? item xml-attribute?) (append item (loop items))) (else - (error "Unknown item passed to html-attrs:" item)))) + (error "Unknown item passed to xml-attrs:" item)))) '()))) -(define (convert-html-string-value value) +(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)) @@ -232,15 +172,93 @@ USA. s)) (make-string 0))) +(define-html-element a inline) +(define-html-element abbr inline) +(define-html-element acronym inline) +(define-html-element address block) +(define-html-element area map empty) +(define-html-element b inline) +(define-html-element base head empty) +(define-html-element bdo inline) +(define-html-element big inline) +(define-html-element blockquote block) +(define-html-element body html) +(define-html-element br inline empty) +(define-html-element button inline) +(define-html-element caption table) +(define-html-element cite inline) +(define-html-element code inline) +(define-html-element col table empty) +(define-html-element colgroup table) +(define-html-element dd dl) +(define-html-element del hybrid) +(define-html-element dfn inline) +(define-html-element div block) +(define-html-element dl block) +(define-html-element dt dl) +(define-html-element em inline) +(define-html-element fieldset block) +(define-html-element form block) +(define-html-element h1 block) +(define-html-element h2 block) +(define-html-element h3 block) +(define-html-element h4 block) +(define-html-element h5 block) +(define-html-element h6 block) +(define-html-element head html) +(define-html-element hr block empty) +(define-html-element html root) +(define-html-element i inline) +(define-html-element img inline empty) +(define-html-element input inline empty) +(define-html-element ins hybrid) +(define-html-element kbd inline) +(define-html-element label inline) +(define-html-element legend fieldset) +(define-html-element li list) +(define-html-element link head empty) +(define-html-element map inline) +(define-html-element meta head empty) +(define-html-element noscript block) +(define-html-element object inline) +(define-html-element ol block) +(define-html-element optgroup select) +(define-html-element option select) +(define-html-element p block) +(define-html-element param object empty) +(define-html-element pre block) +(define-html-element q inline) +(define-html-element samp inline) +(define-html-element script hybrid) +(define-html-element select inline) +(define-html-element small inline) +(define-html-element span inline) +(define-html-element strong inline) +(define-html-element style head) +(define-html-element sub inline) +(define-html-element sup inline) +(define-html-element table block) +(define-html-element tbody table) +(define-html-element td table) +(define-html-element textarea inline) +(define-html-element tfoot table) +(define-html-element th table) +(define-html-element thead table) +(define-html-element title head) +(define-html-element tr table) +(define-html-element tt inline) +(define-html-element ul block) +(define-html-element var inline) + (define (html:href iri . contents) (apply html:a - (html-attrs 'href iri) + (xml-attrs 'href iri) contents)) (define (html:id-def tag . contents) (apply html:a - (html-attrs 'id tag - 'name tag) + (xml-attrs 'id tag + 'name tag) contents)) (define (html:id-ref tag . contents) @@ -259,7 +277,7 @@ USA. (html:meta 'http-equiv name 'content value)) -(define (html:style . keyword-list) +(define (html:style-attr . keyword-list) (let loop ((bindings keyword-list)) (if (and (pair? bindings) (symbol? (car bindings)) @@ -274,16 +292,4 @@ USA. (begin (if (not (null? bindings)) (error:wrong-type-argument keyword-list "keyword list" 'STYLE)) - "")))) - -(define (html:comment . strings) - (make-xml-comment - (let* ((s (apply string-append (map canonicalize-char-data strings))) - (ws (utf8-string->wide-string s)) - (n (wide-string-length ws))) - (if (fix:> n 0) - (string-append - (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 + "")))) \ No newline at end of file diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm index e68a12824..20ebaa6c6 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.42 2004/06/28 03:26:20 cph Exp $ +$Id: xml-struct.scm,v 1.43 2004/07/19 04:45:20 cph Exp $ Copyright 2001,2002,2003 Massachusetts Institute of Technology @@ -452,4 +452,17 @@ USA. (let ((name (xml-attribute-name attr))) (if (xml-name=? name 'xmlns) (null-xml-name-prefix) - (xml-name-local name))))))) \ No newline at end of file + (xml-name-local name))))))) + +;; Convenience procedure +(define (xml-comment . strings) + (make-xml-comment + (let* ((s (apply string-append (map canonicalize-char-data strings))) + (ws (utf8-string->wide-string s)) + (n (wide-string-length ws))) + (if (fix:> n 0) + (string-append + (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 diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 8fedd0f68..97a453243 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.44 2004/07/18 04:34:06 cph Exp $ +$Id: xml.pkg,v 1.45 2004/07/19 04:45:15 cph Exp $ Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology @@ -206,6 +206,7 @@ USA. xml-attribute-value xml-attribute? xml-char-data? + xml-comment xml-comment-text xml-comment? xml-content-item? @@ -266,9 +267,7 @@ USA. %make-xml-parameter-!entity %make-xml-parameter-entity-ref %make-xml-processing-instructions - %make-xml-unparsed-!entity) - (export (runtime xml html) - canonicalize-char-data)) + %make-xml-unparsed-!entity)) (define-package (runtime xml parser) (files "xml-chars" "xml-parser") @@ -299,9 +298,14 @@ USA. (files "xhtml") (parent (runtime xml)) (export () - html-attrs + guarantee-html-element + guarantee-html-element-name html-dtd html-element? + html-element-context + html-element-name? + html-element-name-context + html-element-names html-external-dtd html-iri html:a @@ -312,8 +316,14 @@ USA. html:acronym? html:address html:address? + html:area + html:area? html:b html:b? + html:base + html:base? + html:bdo + html:bdo? html:big html:big? html:blockquote @@ -334,15 +344,12 @@ USA. html:col? html:colgroup html:colgroup? - html:comment html:dd html:dd? - html:defn - html:defn? html:del html:del? - html:dir - html:dir? + html:dfn + html:dfn? html:div html:div? html:dl @@ -351,6 +358,8 @@ USA. html:dt? html:em html:em? + html:fieldset + html:fieldset? html:form html:form? html:h1 @@ -363,6 +372,8 @@ USA. html:h4? html:h5 html:h5? + html:h6 + html:h6? html:head html:head? html:hr @@ -383,16 +394,22 @@ USA. html:ins? html:kbd html:kbd? + html:label + html:label? + html:legend + html:legend? html:li html:li? html:link html:link? - html:listing - html:listing? - html:menu - html:menu? + html:map + html:map? html:meta html:meta? + html:noscript + html:noscript? + html:object + html:object? html:ol html:ol? html:optgroup @@ -401,13 +418,13 @@ USA. html:option? html:p html:p? + html:param + html:param? html:pre html:pre? html:q html:q? html:rel-link - html:s - html:s? html:samp html:samp? html:script @@ -418,12 +435,12 @@ USA. html:small? html:span html:span? - html:strike - html:strike? html:strong html:strong? html:style + html:style-attr html:style-link + html:style? html:sub html:sub? html:sup @@ -448,9 +465,8 @@ USA. html:tr? html:tt html:tt? - html:u - html:u? html:ul html:ul? html:var - html:var?)) \ No newline at end of file + html:var? + xml-attrs)) \ No newline at end of file -- 2.25.1