From: Paul Foley
Subject: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <m2r9lwvw2g.fsf@mycroft.actrix.gen.nz>
I wrote the following in response to David Bakhash's request for
something better than FORMAT for producing HTML.

Example:

  (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))))))

Just print to *standard-output* inside the scope of the HTML macro to
produce output (with automatic conversion of < to &lt;, etc., on
Allegro CL); a string automatically gets printed (so watch out for
body forms that can return a string, like PRINC, or you might get two
copies)


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

;;; $Revision: 1.2 $
;;; Copyright � 1999 Paul Foley (·······@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"
			  (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))

(defmacro deftextform (name)
  `(defmacro ,name (&body body)
     `(generate ,',name (a address h1 h2 h3 h4 h5 h6 p pre dd dt li)
		("<~A>" ',',name) ("</~A>" ',',name) ,@body)))

(deftextform cite)
(deftextform code)
(deftextform em)
(deftextform kbd)
(deftextform samp)
(deftextform strong)
(deftextform var)
(deftextform dfn)
(deftextform strike)

(deftextform b)
(deftextform i)
(deftextform tt)
(deftextform u)


(eval-when (:load-toplevel :execute)
  (defentity #x22 "&quot;")
  (defentity #x26 "&amp;")
  (defentity #x3c "&lt;")
  (defentity #x3e "&gt;"))


-- 
Nomina stultorum in parietibus et portis semper videmus.      -- Cicero

(setq reply-to
  (concatenate 'string "Paul Foley " "<mycroft" '(··@) "actrix.gen.nz>"))
From: David Bakhash
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <cxjiu7855wv.fsf@acs5.bu.edu>
wow.  Just for me :-)

looks real nice.

dave
From: Christopher R. Barry
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <87673727l2.fsf@2xtreme.net>
Paul Foley <···@below> writes:

> I wrote the following in response to David Bakhash's request for
> something better than FORMAT for producing HTML.
> 
> Example:
> 
>   (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))))))

In <················@naggum.no>[1] Erik Naggum wrote:

  so if we allow the same kind of pun on name spaces as Common Lisp already
  uses in (foo bar) where FOO is in the function namespace and bar is in the
  value namespace, my suggestion is ((foo :bar 1) "zot"), which I think is a
  clear winner over the runner-up (foo (:bar 1) "zot") for the simple reason
  that you can view (foo :bar 1) as a function call that returns a function
  that can deal with the contents.  experienced Lisp or Scheme programmers
  may think of this as "currying".

Christopher

1. http://x35.deja.com/[ST_rn=ps]/getdoc.xp?AN=491129293&CONTEXT=932973014.768671902&hitnum=4
From: ········@cc.hut.fi
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <m36737s4xq.fsf@mu.tky.hut.fi>
> In <················@naggum.no>[1] Erik Naggum wrote:
> 
>   so if we allow the same kind of pun on name spaces as Common Lisp already
>   uses in (foo bar) where FOO is in the function namespace and bar is in the
>   value namespace, my suggestion is ((foo :bar 1) "zot"), which I think is a
>   clear winner over the runner-up (foo (:bar 1) "zot") for the simple reason
>   that you can view (foo :bar 1) as a function call that returns a function
>   that can deal with the contents.  experienced Lisp or Scheme programmers
>   may think of this as "currying".

My personal favourite is (foo :bar 1 "zot") which can be seen as a
simple function call with keyword and &rest arguments.

Hannu Rummukainen
From: Gareth McCaughan
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <86vhb7ox53.fsf@g.local>
········@cc.hut.fi writes:

> My personal favourite is (foo :bar 1 "zot") which can be seen as a
> simple function call with keyword and &rest arguments.

Unfortunately you have to parse them yourself, since &key and &rest
don't mix in the way you'd want them to for this purpose.

-- 
Gareth McCaughan  ················@pobox.com
sig under construction
From: ········@cc.hut.fi
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <m34sipsyez.fsf@mu.tky.hut.fi>
Gareth McCaughan <················@pobox.com> writes:

> > My personal favourite is (foo :bar 1 "zot") which can be seen as a
> > simple function call with keyword and &rest arguments.
> 
> Unfortunately you have to parse them yourself, since &key and &rest
> don't mix in the way you'd want them to for this purpose.

Of course, but it doesn't matter on the caller side and makes for less
cluttered presentation.

Hannu Rummukainen
From: David Bakhash
Subject: Re: Writing HTML (#'format and string interpolation)
Date: 
Message-ID: <cxjhfmq69zi.fsf@acs5.bu.edu>
what Foley did is done the right way.  It should not change in the says that
have been suggested.

Just look at with-open-file and friends.  a () after tags is not a problem,
and later on, and visually, it helps a lot t separate optional fields from the
body, which is the string inside the tag.

that's my vote.  

dave
comp.lang.lisp / 1999 / jul