Uses a custom compiler no longer using FORMAT, thus escaping ~A won't be
[mmondor.git] / mmsoftware / cl / test / html.lisp
1 ;;;; $Id: html.lisp,v 1.9 2011/08/19 03:34:39 mmondor Exp $
2 ;;;;
3 ;;;; Test HTML+code template compiler
4 ;;;; Copyright (c) 2011, Matthew Mondor
5 ;;;; ALL RIGHTS RESERVED.
6
7 ;;;; XXX TODO XXX
8 ;;;; - HTML-safe escaping of general content, including XHTML oddities
9
10
11 (defparameter *html-mode* :xhtml)
12
13
14 ;;; XXX Returns HTML-safe copy of STRING
15 (defun html-escape (string)
16 string)
17
18 ;;; Given keyword SYMBOL, returns two values: the tag name string and
19 ;;; a boolean on if the tag should be matched with a closing tag.
20 (defun symbol-tag (symbol)
21 (let* ((name (string-downcase (symbol-name symbol)))
22 (not-close-p (char= #\/ (schar name 0)))
23 (tag (if not-close-p (subseq name 1) name)))
24 (values tag (not not-close-p))))
25
26 ;;; Parses tag and its attributes if any, starting at LIST.
27 ;;; Returns the tag name, if it must be matched by a closing tag,
28 ;;; its attributes list as well as the tree position at which to resume
29 ;;; parsing.
30 ;;; The returned list is left in reverse-order which is better for our
31 ;;; caller, HTML-PARSE-R.
32 (defun html-tag-parse (list)
33 (macrolet ((add (i)
34 `(push ,i attr)))
35 (let* ((tag nil)
36 (close-p nil)
37 (attr '())
38 (attr-state :symbol)
39 (position
40 (loop
41 for c on list
42 do
43 (block nil
44 (let ((i (car c)))
45
46 ;; Tag itself, init state
47 (when (null tag)
48 (multiple-value-bind (tag-name tag-close-p)
49 (symbol-tag i)
50 (setf tag tag-name
51 close-p tag-close-p)
52 (add (format nil "<~A" tag-name)))
53 (when (and (eq :html i) (eq :xhtml *html-mode*))
54 (add (copy-seq
55 " xmlns=\"http://www.w3.org/1999/xhtml\"")))
56 (return))
57
58 ;; Attributes if any
59 (when (and (eq :symbol attr-state)
60 (keywordp i))
61 (multiple-value-bind (tag-name tag-close-p)
62 (symbol-tag i)
63 (cond ((and (not tag-close-p)
64 (eq :xhtml *html-mode*))
65 (add (format nil " ~A=\"~A\""
66 tag-name tag-name)))
67 (tag-close-p
68 (add (format nil " ~A=" tag-name))
69 (setf attr-state :value))
70 (t
71 (add (format nil " ~A" tag-name)))))
72 (return))
73 (when (and (eq :value attr-state)
74 (or (atom i)
75 (and (listp i)
76 (not (keywordp (first i))))))
77 (cond ((stringp i)
78 (add (format nil "\"~A\"" i)))
79 ((or (atom i)
80 (and (listp i)
81 (not (keywordp (first i)))))
82 (add (copy-seq "\""))
83 (add i)
84 (add (copy-seq "\""))))
85 (setf attr-state :symbol)
86 (return)))
87
88 (loop-finish))
89 finally
90 (progn
91 (add (copy-seq
92 (if (and (eq :xhtml *html-mode*)
93 (not close-p))
94 " />"
95 ">")))
96 (return c)))))
97 (values tag close-p attr position))))
98
99 ;;; Recursive tree parsing function
100 (defun html-parse-r (tree)
101 (macrolet ((add (i)
102 `(push ,i out)))
103 (let ((out '())
104 (tag nil)
105 (close-p t))
106 (loop
107 for c on tree
108 do
109 (block nil
110 (tagbody
111 continue
112 (let ((i (car c))
113 (last-p (null (cdr c))))
114
115 ;; Ready to scan a new tag
116 (when (and (null tag) (keywordp i))
117 (multiple-value-bind (tag-name tag-close-p tag-list pos)
118 (html-tag-parse c)
119 (when (and (eq :html i) (eq :xhtml *html-mode*))
120 (add (copy-seq
121 "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
122 <!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\"
123 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">
124 ")))
125 (setf out (append tag-list out)
126 tag tag-name
127 close-p tag-close-p
128 c pos)
129 (when (and (eq :head i) (eq :xhtml *html-mode*))
130 (add (copy-seq "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />")))
131 (if c (go continue) (return))))
132
133 ;; Content
134 (cond ((stringp i)
135 (add (copy-seq i)))
136 ((or (atom i)
137 (and (listp i)
138 (not (keywordp (first i)))))
139 (add i))
140 ((listp i)
141 (setf out (append (reverse (html-parse-r i)) out))))
142
143 ;; Close tag if needed
144 (when (and last-p tag close-p)
145 (add (format nil "</~A>" tag))
146 (setf tag nil
147 close-p t))))))
148 (reverse out))))
149
150 ;;; Optimizes the tree produced by HTML-PARSE-R, concatenating strings.
151 (defun html-coalesce (list)
152 (let ((out '())
153 (last nil))
154 (mapc
155 #'(lambda (i)
156 (let ((s (stringp i)))
157 (if (and last s)
158 (rplaca out (concatenate 'string (car out) i))
159 (progn
160 (setf last s)
161 (push i out)))))
162 list)
163 (reverse out)))
164
165 ;;; Utility macro to generate easily HTML from Common Lisp code.
166 ;;; The HTML template is converted to a list of strings and objects
167 ;;; at compile-time, and the non-HTML Lisp code objects are evaluated
168 ;;; at run-time.
169 ;;; Note that tags and attributes are represented using keyword symbols and
170 ;;; that sublists represent content. Tags are automatically closed unless
171 ;;; the tag symbol begins with a '/'. Likewise, attributes without a value
172 ;;; (such as OPTION's SELECTED attribute) must also be prefixed with '/'.
173 ;;; Literal text should be strings (enclosed in double quotes), and CL
174 ;;; atoms and lists may be used as placeholders for dynamic content,
175 ;;; and may be placed either as attribute values or in general content.
176 (defmacro do-html (stream tree)
177 (let ((list (html-coalesce (html-parse-r tree)))
178 (s-stream (gensym)))
179 (if stream
180 `(let ((,s-stream ,stream))
181 ,@(mapcar #'(lambda (i)
182 (if (stringp i)
183 `(write-string ,i ,s-stream)
184 `(format ,s-stream "~A" ,i)))
185 list)
186 nil)
187 `(with-output-to-string (,s-stream)
188 ,@(mapcar #'(lambda (i)
189 (if (stringp i)
190 `(write-string ,i ,s-stream)
191 `(format ,s-stream "~A" ,i)))
192 list)))))
193
194 ;;; Utility macro for sane and easy loops within HTML constructs.
195 (defmacro do-html-loop ((&body loop-clause) &body body)
196 (let ((s-stream (gensym)))
197 `(with-output-to-string (,s-stream)
198 (loop
199 ,@loop-clause
200 do
201 (do-html ,s-stream
202 ,@body)))))
203
204
205
206 ;;; Tests
207
208 #+test
209 (defun http-reply (code message &optional description)
210 (let ((title (format nil "~A - ~A" code message)))
211 (do-html t
212 (:html (:head (:title title))
213 (:body
214 (:h1 title)
215 (if description
216 (do-html nil
217 (:p description))
218 "")
219 (:small (format nil "~A/~A"
220 (lisp-implementation-type)
221 (lisp-implementation-version))))))))
222
223 #+test
224 (defun random-page (&key (trs 10) (tds 10) (rnd 1000))
225 (do-html t
226 (:html (:head (:title "Random page"))
227 (:body
228 (:h1 "Random page")
229 (:table
230 (do-html-loop (repeat trs)
231 (:tr
232 (do-html-loop (repeat tds)
233 (:td (random rnd))))))))))
234
235 #+test
236 (defun results-page (list)
237 (do-html t
238 (:html (:head (:title "Results"))
239 (:body
240 (:h1 "Results")
241 (:table
242 (do-html-loop (for i in list)
243 (:tr (:td i))))))))