SE701:April 2

;; 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* " "))))