From 8503244b39dfd86bde76c32ee61e3101451c5e70 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Jul 2004 19:05:36 +0000 Subject: [PATCH] Move xhtml support into this package. Change names to contain "html" so they don't conflict with others. --- v7/src/xml/xhtml.scm | 258 +++++++++++++++++++++++++++++++++++++++++++ v7/src/xml/xml.pkg | 163 ++++++++++++++++++++++++++- 2 files changed, 419 insertions(+), 2 deletions(-) create mode 100644 v7/src/xml/xhtml.scm diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm new file mode 100644 index 000000000..f1c473419 --- /dev/null +++ b/v7/src/xml/xhtml.scm @@ -0,0 +1,258 @@ +#| -*-Scheme-*- + +$Id: xhtml.scm,v 1.1 2004/07/12 19:05:17 cph Exp $ + +Copyright 2002,2003,2004 Massachusetts Institute of Technology + +This file is part of MIT/GNU Scheme. + +MIT/GNU Scheme is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +MIT/GNU Scheme is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +|# + +;;;; XHTML support + +(declare (usual-integrations)) + +(define html-external-dtd + (make-xml-external-id "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd")) + +(define html-dtd + (make-xml-dtd 'html html-external-dtd '())) + +(define html-iri + (make-xml-namespace-iri "http://www.w3.org/1999/xhtml")) + +(define-syntax define-standard-element + (sc-macro-transformer + (lambda (form environment) + environment + (if (syntax-match? '(IDENTIFIER) (cdr form)) + (let ((name (cadr form))) + `(BEGIN + (DEFINE ,(symbol-append 'HTML: name) + (STANDARD-ELEMENT-CONSTRUCTOR ',name HTML-IRI)) + (DEFINE ,(symbol-append 'HTML: name '?) + (STANDARD-ELEMENT-PREDICATE ',name HTML-IRI)))) + (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-element-predicate simple iri) + (let ((name (make-xml-name simple 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 ((xml-content-item? item) (cons item tail)) + ((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 (convert-html-string-value value) + (cond ((symbol? value) (symbol-name value)) + ((number? value) (number->string value)) + ((xml-namespace-iri? value) (xml-namespace-iri-string value)) + (else (error:wrong-type-datum value "string value")))) + +(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 (empty-element-constructor simple iri) + (let ((name (make-xml-name simple iri))) + (lambda keyword-list + (make-xml-element name + (if (and (pair? keyword-list) + (list-of-type? (car keyword-list) + xml-attribute?) + (null? (cdr keyword-list))) + (car keyword-list) + (apply html-attrs keyword-list)) + '())))) + +(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-attrs . keyword-list) + (let loop ((bindings keyword-list)) + (if (and (pair? bindings) + (xml-name? (car bindings)) + (pair? (cdr bindings))) + (let ((value (cadr bindings)) + (tail (loop (cddr bindings)))) + (if value + (cons (make-xml-attribute + (car bindings) + (cond ((eq? value #t) (symbol-name (car bindings))) + ((xml-char-data? value) value) + (else (convert-html-string-value value)))) + tail) + tail)) + (begin + (if (not (null? bindings)) + (error:wrong-type-argument keyword-list + "keyword list" + 'HTML-ATTRS)) + '())))) + +(define (html:href iri . contents) + (apply html:a + (html-attrs 'href iri) + contents)) + +(define (html:id-def tag . contents) + (apply html:a + (html-attrs 'id tag + 'name tag) + contents)) + +(define (html:id-ref tag . contents) + (apply href (string-append "#" tag) contents)) + +(define (html:rel-link rel iri) + (html:link 'rel rel + 'href iri)) + +(define (html:style-link iri) + (html:link 'rel "stylesheet" + 'href iri + 'type "text/css")) + +(define (html:http-equiv name value) + (html:meta 'http-equiv name + 'content value)) + +(define (html:style . keyword-list) + (let loop ((bindings keyword-list)) + (if (and (pair? bindings) + (symbol? (car bindings)) + (pair? (cdr bindings)) + (string? (cadr bindings))) + (string-append (symbol-name (car bindings)) + ": " + (cadr bindings) + (if (pair? (cddr bindings)) + (string-append "; " (loop (cddr bindings))) + ";")) + (begin + (if (not (null? bindings)) + (error:wrong-type-argument keyword-list "keyword list" 'STYLE)) + "")))) + +(define (html:comment . strings) + (make-xml-comment (string-append " " (apply string-append strings) " "))) \ No newline at end of file diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg index 989123a60..8f960cfcb 100644 --- a/v7/src/xml/xml.pkg +++ b/v7/src/xml/xml.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: xml.pkg,v 1.41 2004/06/28 03:25:57 cph Exp $ +$Id: xml.pkg,v 1.42 2004/07/12 19:05:36 cph Exp $ Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology @@ -291,4 +291,163 @@ USA. write-xml write-xml-file xml->string - xml->wide-string)) \ No newline at end of file + xml->wide-string)) + +(define-package (runtime xml html) + (files "xhtml") + (parent (runtime xml)) + (export () + html-attrs + html-dtd + html-external-dtd + html-iri + html:a + html:a? + html:abbr + html:abbr? + html:acronym + html:acronym? + html:address + html:address? + html:b + html:b? + html:big + html:big? + html:blockquote + html:blockquote? + html:body + html:body? + html:br + html:br? + html:button + html:button? + html:caption + html:caption? + html:cite + html:cite? + html:code + html:code? + html:col + 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:div + html:div? + html:dl + html:dl? + html:dt + html:dt? + html:em + html:em? + html:form + html:form? + html:h1 + html:h1? + html:h2 + html:h2? + html:h3 + html:h3? + html:h4 + html:h4? + html:h5 + html:h5? + html:head + html:head? + html:hr + html:hr? + html:href + html:html + html:html? + html:http-equiv + html:i + html:i? + html:id-def + html:id-ref + html:img + html:img? + html:input + html:input? + html:ins + html:ins? + html:kbd + html:kbd? + html:li + html:li? + html:link + html:link? + html:listing + html:listing? + html:menu + html:menu? + html:meta + html:meta? + html:ol + html:ol? + html:optgroup + html:optgroup? + html:option + html:option? + html:p + html:p? + html:pre + html:pre? + html:q + html:q? + html:rel-link + html:s + html:s? + html:samp + html:samp? + html:script + html:script? + html:select + html:select? + html:small + html:small? + html:span + html:span? + html:strike + html:strike? + html:strong + html:strong? + html:style + html:style-link + html:sub + html:sub? + html:sup + html:sup? + html:table + html:table? + html:tbody + html:tbody? + html:td + html:td? + html:textarea + html:textarea? + html:tfoot + html:tfoot? + html:th + html:th? + html:thead + html:thead? + html:title + html:title? + html:tr + html:tr? + html:tt + html:tt? + html:u + html:u? + html:ul + html:ul? + html:var + html:var?)) \ No newline at end of file -- 2.25.1