;;;; HTML.LISP --- HTML production macros

;;; $Revision: 1.2 $
;;; Copyright  1999 Paul Foley (mycr...@actrix.gen.nz)
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.

(defpackage "HTML"
  (:use "COMMON-LISP" #+Allegro "STREAM")
  (:export "HTML" "HEAD" "ISINDEX" "BASE" "LINK" "META" "TITLE"
           "BODY" "H1" "H2" "H3" "H4" "H5" "H6" "P" "A" "PRE" "ADDRESS"
           "BLOCKQUOTE" "IMG" "BR" "HR" "DL" "DT" "DD" "OL" "UL" "LI"
           "FORM" "INPUT" "SELECT" "OPTION" "TEXTAREA"
           "TABLE" "CAPTION" "TR" "TH" "TD"
           "CITE" "CODE" "EM" "KBD" "SAMP" "STRONG" "VAR" "DFN" "STRIKE"
           "B" "I" "TT" "U"))

(in-package "HTML")

(defvar *html-tag* nil)
(defvar *html-entities* (make-hash-table))
(defvar *html-output* nil)

(define-condition html-nesting-error (error)
  ((tag :reader html-error-tag :initarg :tag)
   (container :reader html-error-container :initarg :container))
  (:report
   (lambda (condition stream)
     (format stream "The HTML element <~A> is not allowed inside <~A>."
             (html-error-tag condition) (html-error-container condition)))))

#+Allegro ;; has Gray streams
(defclass html-output-stream (fundamental-character-output-stream)
  ((real-stream :initarg :stream :reader html-output-stream-stream)))

#+Allegro
(defmethod print-object ((object html-output-stream) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "for ~A" (html-output-stream-stream object))))

#+Allegro
(defmethod stream-write-string ((stream html-output-stream) string
                                &optional (start 0) (end (length string)))
  (if *html-output*
      (princ (subseq string start end) (html-output-stream-stream stream))
    (let ((str (make-array (- end start) :adjustable t :fill-pointer 0
                           :element-type 'base-char)))
      (do* ((index start (1+ index))
            (char (char string index) (char string index))
            (entity #1=(gethash char *html-entities*) #1#))
          ((= index end) (princ str (html-output-stream-stream stream)))
        (if entity
            (loop for char across entity do (vector-push-extend char str))
          (vector-push-extend char str)))))
  string)

#+Allegro
(defmethod stream-write-char ((stream html-output-stream) character)
  (if *html-output*
      (princ character (html-output-stream-stream stream))
    (let ((entity (gethash character *html-entities*)))
      (if entity
          (princ entity (html-output-stream-stream stream))
        (princ character (html-output-stream-stream stream)))))
  character)

#+Allegro
(defmethod stream-line-column ((stream html-output-stream))
  (stream-line-column (html-output-stream-stream stream)))

#+Allegro
(defmethod stream-finish-output ((stream html-output-stream))
  (finish-output (html-output-stream-stream stream)))

#+Allegro
(defmethod stream-force-output ((stream html-output-stream))
  (force-output (html-output-stream-stream stream)))

#+Allegro
(defmethod stream-clear-output ((stream html-output-stream))
  (clear-output (html-output-stream-stream stream)))

#+Allegro
(defmethod close ((stream html-output-stream) &key abort)
  (close (html-output-stream-stream stream) :abort abort))

(defun make-html-stream (stream)
  #+Allegro (make-instance 'html-output-stream :stream stream)
  #-Allegro stream)

(defmacro defentity (code entity)
  `(setf (gethash (code-char ,code) *html-entities*) ,entity))

(defmacro html-format (dest control &rest args)
  `(let ((*html-output* t))
     (format ,dest ,control ,@args)))

(defmacro when-valid (tag containers &body body)
  `(progn
     (unless (member *html-tag* ',containers :test #'eq)
       (cerror "Output it anyway."
               'html-nesting-error :tag ',tag :container *html-tag*))
     (let ((*html-tag* ',tag))
       ,@body)))

(defmacro generate (tag containers (start &rest start-args)
                        (end &rest end-args)
                        &body body)
  (let ((value (gensym)))
    `(when-valid ,tag ,containers
       (html-format t ,start ,@start-args)
       (let ((,value (progn ,@body)))
         (when (stringp ,value)
           (princ ,value)))
       (html-format t ,end ,@end-args))))

(defmacro deftag (name attributes containers
                       &key newline-outside newline-inside empty)
  `(defmacro ,name ((&key ,@(loop for x in attributes
                              collect (if (symbolp x) x (car x))))
                    ,@(unless empty '(&body body)))
     `(generate ,',name ,',containers
                (,(format nil "~A<~A~{~~@[ ~A~:[~~*~;=~:*~A~]~~]~}>~A"
                          (if ,newline-outside "~&" "")
                          ',name
                          ',(loop for x in attributes
                              collect (if (symbolp x) x (car x))
                              collect (cond ((symbolp x) "~S")
                                            ((eq (cadr x) 'boolean) nil)
                                            ((eq (cadr x) 'string) "~S")
                                            ((eq (cadr x) 'number) "~D")
                                            ((eq (cadr x) 'symbol)
                                                           "~(\"~A\"~)")
                                            (t (error "Unrecognised ~
                                                             attribute type: ~
                                                             ~S" (cadr x)))))
                          (if ,(or newline-inside (and empty newline-outside))
                              "~%"
                            ""))
                 ,,@(loop for x in attributes
                      collect (if (symbolp x) x (car x))))
                (,,(if empty "" `(format nil "~A</~A>~A"
                                         (if ,newline-inside "~&" "")
                                         ',name
                                         (if ,newline-outside "~%" ""))))
                ,@,(unless empty 'body))))

(defmacro html ((&key stream) &body body)
  `(let ((*standard-output* (make-html-stream
                             ,(or stream '*standard-output*))))
     (generate html (nil) ("~&<HTML>~%") ("~&</HTML>~%") ,@body)))

(deftag head () (html) :newline-outside t :newline-inside t)
(deftag isindex (href prompt) (head) :newline-outside t :empty t)
(deftag base (href) (head) :newline-outside t :empty t)
(deftag link (href rel title) (head) :newline-outside t :empty t)
(deftag meta (http-equiv name content) (head) :newline-outside t :empty t)
(deftag title () (head) :newline-outside t)

(deftag body (background) (html) :newline-outside t :newline-inside t)
(deftag h1 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag h2 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag h3 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag h4 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag h5 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag h6 ((align symbol)) (blockquote body form) :newline-outside t)
(deftag p ((align symbol)) (blockquote body form dd li) :newline-outside t)
(deftag a (href name) (address h1 h2 h3 h4 h5 h6 p pre dt dd li))
(deftag pre () (blockquote body form dd li) :newline-outside t)
(deftag address () (blockquote body form))
(deftag blockquote () (blockquote body form dd li)
  :newline-outside t :newline-inside t)
(deftag img (alt (align symbol) (ismap boolean) src
                 (height number) (width number) units)
  (a h1 h2 h3 h4 h5 h6 p address dd dt li)
  :empty t)

(deftag br ((clear boolean)) (a address h1 h2 h3 h4 h5 h6 p dd dt li)
  :newline-inside t :empty t)
(deftag hr () (blockquote body form) :newline-outside t :empty t)

(deftag dl ((compact boolean)) (blockquote body form dd li)
  :newline-outside t :newline-inside t)
(deftag dt () (dl) :newline-outside t)
(deftag dd () (dl) :newline-outside t)

(deftag ol ((compact boolean) (continue boolean) (seqnum number))
  (blockquote body form dd li)
  :newline-outside t :newline-inside t)
(deftag ul ((compact boolean)) (blockquote body form dd li)
  :newline-outside t :newline-inside t)
(deftag li () (ol ul) :newline-outside t)

(deftag form (action enctype (method symbol)) (blockquote body dd li)
  :newline-outside t :newline-inside t)
(deftag input ((align symbol) (checked boolean) (maxlength number)
               name (size number) src (type symbol) value)
  (form) :empty t)
(deftag select ((multiple boolean) name (size number)) (form))
(deftag option (value (selected boolean) (disabled boolean)) (select))
(deftag textarea (name (rows number) (cols number)) (form))

(deftag table ((border boolean) (cellpadding number) (cellspacing number)
               (width number))
  (blockquote body form dd li td th)
  :newline-outside t :newline-inside t)
(deftag caption ((align symbol)) (table) :newline-outside t)
(deftag tr ((align symbol) (valign symbol)) (table) :newline-outside t)
(deftag th ((align symbol) (valign symbol) (rowspan number) (colspan number)
            (nowrap boolean))
  (tr))
(deftag td ((align symbol) (valign symbol) (rowspan number) (colspan number)
            (nowrap boolean))
  (tr))

(defun demo ()
 (html (:stream output-stream)
    (head ()
     (title () "HTML production example"))
    (body ()
     (h1 (:align :center) "A table")
     (table (:border t)
        (tr ()
         (th () "Column 1")
          (th () "Column 2")
          (th () "Column 3"))
        (dolist (row '((1 "two" 3) (4 5 6) (7 8 9)))
          (tr ()
            (td () (princ (first row)) nil)
            (td () (princ (second row)) nil)
            (td () (princ (third row)) nil)))))))