;     Guile Scheme xhtml generator, part of Guile Web
;     Copyright (C) 2002,2004 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 html)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (oop goops)
  #:use-module (ice-9 pretty-print)
  #:use-syntax (ice-9 syncase)
  #:export (empty-tag non-empty-tag <html-document>
	    xhtml:output-port xhtml:common-attributes
	    xhtml:print xhtml:DOCUMENT xhtml:real-print xhtml:dtd
	    xhtml:tags))
		    
(define-class <html-document> ()
  (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 <xhtml-tag> ()
  (tag-tree #:init-keyword #:tag-tree
	    #:accessor tag-tree))

(define-generic xhtml-tag?)

(define-method (xhtml-tag? (tag <top>)) #f)
(define-method (xhtml-tag? (tag <xhtml-tag>)) #t)

(define xhtml:DOCUMENT (make-fluid))
(fluid-set! xhtml:DOCUMENT (make <html-document>))

(define-syntax xhtml:print
  (lambda (exp)
    (syntax-case exp ()
      ((_ exp1 exps ...)
       (syntax
	(if (eq? (class-of exp1) <html-document>)
	    (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 (item <xhtml-tag>) (port <port>))
  (for-each (lambda (x) (display x port)) (tag-tree item)))

(define-method (display (item <xhtml-tag>))
  (display item (current-output-port)))

(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)))
			      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))))
	     (format #f "<~A~{~{ ~A=~S~}~} />" name new-attlist))))

(define (non-empty-tag-start name attributes)
  (lambda* (#:key (atts '()))
	   (let ((new-attlist (non-empty-attributes
			       (merge-atts attributes atts))))
	     (format #f "<~A~{~{ ~A=~S~}~}>" name new-attlist))))

(define (non-empty-tag-end name)
  (lambda ()
    (format #f "</~A>" name)))

(define (non-empty-tag name attributes)
  (lambda* (#:key (atts '()) #:rest elements)
	   (let ((new-attlist (non-empty-attributes
			       (merge-atts attributes atts))))

	     ;; The following is a hack to get around the broken
	     ;; lambda* in Guile 1.6.4. Once it is fixed this will be
	     ;; removed (it's another N iterations over the list and
	     ;; therefore evil).
	     (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 <xhtml-tag>
	       #:tag-tree
	       (list
		(format #f "<~A~{~{ ~A=~S~}~}>" name new-attlist)
		(make <xhtml-tag> #:tag-tree elements)
		(format #f "</~A>" name))))))

; (define-syntax define-tag!
;   (lambda (exp)
;     (syntax-case exp ()
;       ((_ name attributes empty?)
;        (syntax
; 	(begin
; 	  (let* ((tag-symbol (string->symbol
; 			      (string-append
; 			       "xhtml:"
; 			       (symbol->string 'name))))
; 		 (symbol-list (list tag-symbol)))
; 	    (module-define! (current-module)
; 			    tag-symbol
; 			    (if empty?
; 				(empty-tag     'name 'attributes)
; 				(non-empty-tag 'name 'attributes)))
; 	    (cond ((not empty?)
; 		   (module-define! (current-module)
; 				   (symbol-append tag-symbol '-start)
; 				   (non-empty-tag-start 'name 'attributes))
; 		   (module-define! (current-module)
; 				   (symbol-append tag-symbol '-end)
; 				   (non-empty-tag-end 'name))
; 		   (set! symbol-list (append!
; 				      symbol-list
; 				      (list
; 				       (symbol-append tag-symbol '-start)
; 				       (symbol-append tag-symbol '-end))))))
; 	    (module-export! (current-module)
; 			    symbol-list))))))))

(define* (xhtml:dtd #:key (atts '((encoding "iso-8859-1"))) #:rest elements)
  (make <xhtml-tag>
    #:tag-tree
    (list
     (format #f "<?xml version=\"1.0\" ~{~{ ~A=~S~}~} />~%<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n\t\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">~%"  atts)
     (make <xhtml-tag> #:tag-tree elements))))

(define (xhtml:tags . tags)
  (make <xhtml-tag> #:tag-tree tags))

(load-from-path "web/html/html-defined.scm")