;; HTML generation
;; <p>This is a paragraph <i>with <b>italics</b></i> <b>with bold</b> </p>
;; p entity
;; text "This is a paragraph "
;; i entity
;; text "with "
;; b entity
;; (write-html (:p "This is < > & a paragraph " (:i with (:b italics))))
;; (write-html "simple string")
;; (write-html 'symbol)
;; also: attributes, <p class="main" style="...">
;; (:p :class "main" :style "..." stuff ...)
(defvar *html-output* *standard-output*)
(defvar *html-escapes* '((#\> . ">")
(#\< . "<")
(#\& . "&")))
(defvar *attr-escapes* '((#\> . ">")
(#\< . "<")
(#\& . "&")
(#\" . """)
(#\' . "'")))
(defvar *escapes* *html-escapes*)
(defun write-html-char (c)
(let ((esc (cdr (find c *escapes* :key #'car))))
(cond
(esc
(format *html-output* "~a" esc))
((standard-char-p c)
(format *html-output* "~a" c))
(t
(format *html-output* "&#~d;" (char-code c))))))
(defun write-html-literal (literal)
(map nil #'write-html-char (format nil "~a" literal)))
(defun html-write-attr (attr)
(if (cdr attr)
(progn
(format *html-output* " ~a=\"" (car attr))
(write-html-literal (cdr attr))
(format *html-output* "\""))
(format *html-output* " ~a" (car attr))))
(defun html-extract (html)
(labels ((html-extract-attrs (attrs elts)
(if (and (keywordp (car elts)) (keywordp (cadr elts)))
;; (:selected :class "foo" ...)
;; --> interpret :selected as a flag (attribute with no value)
(html-extract-attrs (cons (cons (car elts) nil) attrs)
(cdr elts)))
(if (keywordp (car elts))
;; normal :keyword value pair
(html-extract-attrs (cons (cons (car elts) (cadr elts)) attrs)
(cddr elts))
;; end of attributes
(values (car html) (nreverse attrs) elts))))
(html-extract-attrs '() (cdr html))))
(defun write-html (html)
(if (consp html)
(multiple-value-bind (tag attrs elts) (html-extract html)
(format *html-output* "<~a" tag)
(let ((*escapes* *attr-escapes*)) (mapcar #'html-write-attr attrs))
(format *html-output* ">")
(mapcar #'write-html elts)
(format *html-output* "</~a>" tag))
(progn
(write-html-literal html)
(format *html-output* " "))))