home | new paste

(library (html)
  (export ->html element->html content->html)
  (import (chezscheme))

  (define (closing? tag)
    (not (member tag html-void-elements)))

  (define html-void-elements
    '(area base br col command embed hr img input keygen link meta param source track wbr))

  (define (print-attr attr)
      (let ((key (car attr))
            (value (cadr attr)))
        (display " ")
        (display key)
        (display "=\"")
        (display value)
        (display "\"")))

  (define (alist->html alist)
    (cond
      ((null? alist) (display ""))
      ((eq? '% (car alist)) (for-each print-attr (cdr alist)))
      (else (display "error"))))

  (define (content->html content)
    (if (null? content)
      (display "")
      (->html content)))

  (define (what-is x)
      (cond
        ((string? x) 'content)
        ((eq? '% (car x)) 'alist)
        (else 'content)))

  (define (element->template element)
    (cond
      ((eq? 1 (length element))
       (list (car element) '() '()))
      ((and (eq? 2 (length element)) (eq? 'content (what-is (cadr element))))
       (list (car element) '() (cadr element)))
      ((and (eq? 2 (length element)) (eq? 'alist (what-is (cadr element))))
       (list (car element) (cadr element) '()))
      (else (list (car element) (cadr element) (caddr element)))))

  (define (element->html element)
    (let ((e (element->template element)))
      (let ((tag (car e))
            (alist (cadr e))
            (content (caddr e)))
        (display #\<)
        (display tag)
        (alist->html alist)
        (display #\>)
        (content->html content)
        (if (closing? tag)
            (begin
              (display #\<)
              (display #\/)
              (display tag)
              (display #\>))
            (display "")))))

  (define (->html tree)
    (cond
      ((list? tree)
       (for-each (lambda (t)
                   (if (not (string? t))
                     (element->html t)
                     (content->html t)))
                 tree))
      ((string? tree) (display tree))
      ((null? tree) (display ""))
      (else (display "error")))))