hmtl.scm

(library (html)
  (export html display-html)
  (import (rnrs))

  (define short-tags (make-enumeration '(br img link meta)))

  (define (short-tag? t)
    (enum-set-member? t short-tags))
  
  (define (->string obj)
    (cond
      [(string? obj) obj]
      [(eq? (if #f #f) obj) ""]
      [else
       (call-with-string-output-port
         (lambda (p)
           (display obj p)))]))

  (define (alist->hashtable alist)
    (let ([ht (make-hashtable equal-hash equal?)])
      (for-each
        (lambda (x)
          (hashtable-set! ht (car x) (cdr x)))
        alist)
      ht))

  (define html-entity-escapes
    (alist->hashtable '((#\< . "&lt;") (#\> . "&gt;") (#\& . "&amp;") (#\" . "&quot;") (#\' . "&apos;"))))

  (define attr-string-escapes
    (alist->hashtable '((#\\ . "\\\\") (#\' . "\\'"))))

  (define (string-replace str replacements)
    (define strlen (string-length str))
    (define (escape i start)
      (cond
        [(= i strlen) (list (substring str start i))]
        [(hashtable-ref replacements (string-ref str i) #f) =>
         (lambda (rep)
           (cons* (substring str start i) rep
             (escape (+ i 1) (+ i 1))))]
        [else (escape (+ i 1) start)]))
    (apply string-append (escape 0 0)))

  (define (attrs->string attrs)
    (apply string-append
      (map
        (lambda (attr)
          (string-append " "
            (->string (car attr)) "='"
            (string-replace (->string (cdr attr)) attr-string-escapes) "'"))
        attrs)))

  (define join-strings
    (case-lambda
      [(string-list) (join-strings string-list "")]
      [(string-list sep)
       (cond
         [(null? string-list) ""]
         [(null? (cdr string-list)) (car string-list)]
         [else (string-append (car string-list) sep (join-strings (cdr string-list) sep))])]))

  (define node->string
    (case-lambda
      [(tag) (node->string tag '())]
      [(tag attrs . children)
       (let
         ([attr-string (attrs->string attrs)]
          [tag-string (symbol->string tag)])
         (if (null? children)
           (if (short-tag? tag)
             (string-append "<" tag-string attr-string "/>")
             (string-append "<" tag-string attr-string ">" "</" tag-string ">"))
           (string-append "<" tag-string attr-string ">"
             (apply string-append (map html children))
             "</" tag-string attr-string ">")))]))
 
  (define (html obj)
    (cond
      [(pair? obj) (apply node->string obj)]
      [(string? obj) (string-replace obj html-entity-escapes)]
      [(char? obj) (hashtable-ref html-entity-escapes obj (string obj))]
      [else (->string obj)]))

  (define (display-html title . body)
    (display "Content-Type: text/html;charset=utf-8\n\n")
    (display
      (html
        `(html ()
	   (head ()
	     (title () ,title)
	     (meta ((charset . utf-8))))
	   (body () ,@body)))))
)