; Guile Scheme xhtml generator, part of Guile Web ; Copyright (C) 2002,2004,2005 Clinton Ebadi ; This program 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. ; This program 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 this program; if not, write to the Free Software ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA (define-module (web xhtml) #:use-module (ice-9 optargs) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (oop goops) #:use-syntax (ice-9 syncase) #:export (empty-tag non-empty-tag xhtml:output-port xhtml:common-attributes xhtml:print xhtml:DOCUMENT xhtml:real-print xhtml:dtd xhtml:tags xhtml:tag-tree->shtml)) (define-class () (output-port #:init-keyword #:port #:init-form (current-output-port) #:getter xhtml:output-port) (attributes #:init-keyword #:attributes #:init-value '((id "") (class "") (style "") (title "")) #:getter xhtml:common-attributes)) (define-class () (tree #:init-keyword #:tag-tree #:accessor tag-tree) (name #:init-keyword #:name #:accessor tag-name) (atts #:init-keyword #:atts #:accessor tag-atts #:allocation #:instance) (start-or-close #:init-keyword #:start-or-close #:getter tag-start-or-close)) (define-class ()) (define-class ()) (define-class ()) (define-generic xhtml-tag?) (define-method (xhtml-tag? (tag )) #f) (define-method (xhtml-tag? (tag )) #t) (define xhtml:DOCUMENT (make-fluid)) (fluid-set! xhtml:DOCUMENT (make )) (define-syntax xhtml:print (lambda (exp) (syntax-case exp () ((_ exp1 exps ...) (syntax (if (eq? (class-of exp1) ) (with-fluids ((xhtml:DOCUMENT exp1)) (xhtml:real-print exps ...)) (xhtml:real-print exp1 exps ...))))))) (define-generic xhtml:real-print) (define-method (xhtml:real-print . elements) (letrec ((oport (xhtml:output-port (fluid-ref xhtml:DOCUMENT)))) (for-each (lambda (x) (display x oport)) elements))) (define-method (display (tag ) (port )) (format port "<~A~{~{ ~A=~S~}~} />" (tag-name tag) (tag-atts tag))) (define-method (display (tag ) (port )) (case (tag-start-or-close tag) (('start) (format port "<~A~{~{ ~A=~S~}~}>" (tag-name tag) (tag-atts tag))) (('end) (format port "" (tag-name tag))) (else ; normal non-empty tag (format port "<~A~{~{ ~A=~S~}~}>" (tag-name tag) (tag-atts tag)) (for-each (lambda (x) (display x port)) (tag-tree tag)) (format port "" (tag-name tag))))) (define-method (display (tag ) (port )) (format port "~%~%" (tag-atts tag)) (for-each (lambda (x) (display x port)) (tag-tree tag))) (define-method (display (tag ) (port )) (for-each (lambda (x) (display x port))(tag-tree tag))) (define (non-empty-attributes attributes) "returns all non-empty (i.e. not string-null?) attributes from attributes" (let loop ((non-empty (list)) (rest attributes)) (cond ((null? rest) non-empty) (else (if (string-null? (cadar rest)) (loop non-empty (cdr rest)) (loop (cons (car rest) non-empty) (cdr rest))))))) (define (merge-atts tag-defaults tag-values) "returns a new attlist using system for default values" (let ((system-copy (append! (copy-tree (xhtml:common-attributes (fluid-ref xhtml:DOCUMENT))) (copy-tree tag-defaults)))) (for-each (lambda (x) (set! system-copy ;; (list (cdr x)) is used so that the alist ;; entry is a proper list so that format's ;; iteration can use it (assq-set! system-copy (car x) (list (cdr x))))) tag-values) system-copy)) (define (empty-tag name attributes) (lambda* (#:key (atts '())) (let ((new-attlist (non-empty-attributes (merge-atts attributes atts)))) (make #:name name #:atts new-attlist)))) (define (non-empty-tag-start name attributes) (lambda* (#:key (atts '())) (let ((new-attlist (non-empty-attributes (merge-atts attributes atts)))) (make #:name name #:atts new-attlist #:start-or-close 'start)))) (define (non-empty-tag-end name) (lambda () (make #:name name #:start-or-close close))) (define (non-empty-tag name attributes) (lambda* (#:key (atts '()) #:rest elements) (let ((new-attlist (non-empty-attributes (merge-atts attributes atts)))) ;; the #:rest list still contains all of the #:key stuff, ;; we remove it here (set! elements (remove! (let ((del-next #f)) (lambda (e) (cond ((eq? e #:atts) (set! del-next #t) #t) (del-next (set! del-next #f) #t) (else #f)))) elements)) (make #:name name #:atts new-attlist #:start-or-close #f #:tag-tree elements)))) (define xhtml:dtd (let ((default-attributes '((encoding . "iso-8859-1")))) (lambda* (#:key (atts '((encoding . "iso-8859-1"))) #:rest elements) (let ((new-attlist (non-empty-attributes (merge-atts default-attributes atts)))) (make #:tag-tree elements #:atts new-attlist))))) (define (xhtml:tags . tags) (make #:tag-tree tags)) ;;; HtmlPrag (define-generic xhtml:tag-tree->shtml) (define-generic htmlpragize) (define-method (htmlpragize (tag )) (cons* (tag-name tag) (cons* '@ (tag-atts tag)) (map htmlpragize (tag-tree tag)))) (define-method (htmlpragize (tag )) (cons* '*TOP* (map htmlpragize (tag-tree tag)))) (define-method (htmlpragize (tag )) (list (tag-name tag) (cons* '@ (tag-atts tag)))) (define-method (htmlpragize (tag )) (map htmlpragize (tag-tree tag))) (define-method (htmlpragize (item )) (with-output-to-string (lambda () (display item)))) (define-method (xhtml:tag-tree->shtml (tag )) (htmlpragize tag)) (load-from-path "web/html/html-defined.scm")