/[defdoc]/DefDoc/src/layout/html-engine.lisp
ViewVC logotype

Contents of /DefDoc/src/layout/html-engine.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Dec 7 23:27:07 2003 UTC (10 years, 4 months ago) by rjain
Branch: MAIN
Branch point for: defdoc
Initial revision
1 (in-package :defdoc.layout.html-engine)
2
3 ;;;
4 ;;; HTML output library
5 ;;;
6
7 (defvar *suppress-html-tags* nil
8 "Whether to suppress the output of HTML tags. Useful when converting document elements
9 that are defined by HTML to be un-marked-up strings. Does not suppress creation of
10 entities, however. Conversion routines might want to do something intelligent to make up
11 for the lack of markup if the markup is semantically significant.")
12
13 (defvar *html-head-elements* nil
14 "The list of elements to be added to the HEAD when it is generated. For use in document
15 converters that need to add such elements (e.g. META, LINK, BASE, SCRIPT, STYLE), but
16 would still like to use CALL-NEXT-METHOD to avoid re-implementing the standard document
17 code. The elements of this list are parameter lists for WRITE-HTML-TAG. Note that when
18 modifying this variable to include a BASE element, be sure to check for an existing one.")
19
20 (defvar *suppress-html-wrapping* nil
21 "Whether to suppress the pretty-printer wrapping ability. Necessary for preformatted
22 text, e.g.")
23
24 (defvar *document-title*)
25
26 (defvar *html-stream*)
27
28 (defmacro pprint-newline (kind stream)
29 `(unless *suppress-html-wrapping*
30 (cl:pprint-newline ,kind ,stream)))
31
32 (declaim (inline %write-html-attributes))
33 (defun %write-html-attributes (&rest attributes)
34 (loop
35 for (key val . rest) on attributes by #'cddr
36 do (when val
37 (if (eq val t) ;; just print the attribute with no value
38 (write-string (string key) *html-stream*)
39 (progn
40 (write-string (string key) *html-stream*)
41 (write-char #\= *html-stream*)
42 (typecase val
43 (integer (write val :stream *html-stream*))
44 (symbol (write-string (symbol-name val) *html-stream*))
45 (string (write-char #\" *html-stream*)
46 (write-string val *html-stream*)
47 (write-char #\" *html-stream*)))))
48 (when rest
49 (write-char #\space *html-stream*)
50 (pprint-newline :fill *html-stream*)))))
51
52 (defun write-html-attributes (&rest attributes)
53 (when attributes
54 (write-char #\space *html-stream*)
55 (pprint-indent :current 0 *html-stream*)
56 (pprint-newline :miser *html-stream*)
57 #+nil(apply #'%write-html-attributes
58 (engine-specific-option element 'html-engine 'html-attributes))
59 (apply #'%write-html-attributes attributes)))
60
61 (define-compiler-macro write-html-attributes (&whole whole &rest attributes)
62 (when attributes
63 (if (eq (car whole) 'write-html-attributes)
64 `(progn
65 (write-char #\space *html-stream*)
66 (pprint-indent :current 0 *html-stream*)
67 (pprint-newline :miser *html-stream*)
68 #+nil(apply #'%write-html-attributes
69 (engine-specific-option element 'html-engine 'html-attributes))
70 ,@(loop
71 with val-sym = (gensym "VAL-")
72 for (key val . rest) on attributes by #'cddr
73 collect `(let ((,val-sym ,val))
74 (when ,val-sym
75 (if (eq ,val-sym t) ;; just print the attribute with no value
76 (write-string ,(string key) *html-stream*)
77 (progn
78 (write-string ,(string key) *html-stream*)
79 (write-char #\= *html-stream*)
80 (typecase ,val-sym
81 (integer (write ,val-sym :stream *html-stream*))
82 (symbol (write-string (symbol-name ,val-sym)
83 *html-stream*))
84 (string (write-char #\" *html-stream*)
85 (write-string ,val-sym *html-stream*)
86 (write-char #\" *html-stream*)))))
87 ,@(when rest '((write-char #\space *html-stream*)
88 (pprint-newline :fill *html-stream*)))))))
89 whole)))
90
91 (defmacro open-html-tag (tag-name &rest attributes)
92 `(unless *suppress-html-tags*
93 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix ">")
94 (write-string (string ,tag-name) *html-stream*)
95 (write-html-attributes ,@attributes))))
96
97 (defmacro close-html-tag (tag-name)
98 `(unless *suppress-html-tags*
99 (write-string "</" *html-stream*)
100 (write-string (string ,tag-name) *html-stream*)
101 (write-char #\> *html-stream*)))
102
103 (defmacro with-html-block+ ((indent break-style tag &rest attributes) &body body)
104 (let ((tag-sym (gensym "TAG-")))
105 `(progn
106 (pprint-newline :linear *html-stream*)
107 (pprint-logical-block (*html-stream* nil)
108 (let ((,tag-sym ,tag))
109 (open-html-tag ,tag-sym ,@attributes)
110 (pprint-indent :block ,indent *html-stream*)
111 ,(and break-style `(pprint-newline ,break-style *html-stream*))
112 (unwind-protect
113 (progn ,@body)
114 (pprint-indent :block 0 *html-stream*)
115 ,(and break-style `(pprint-newline ,break-style *html-stream*))
116 (close-html-tag ,tag-sym)))))))
117
118 (defmacro with-html-block ((tag &rest attributes) &body body)
119 (let ((tag-sym (gensym "TAG-")))
120 `(progn
121 (pprint-newline :linear *html-stream*)
122 (pprint-logical-block (*html-stream* nil)
123 (let ((,tag-sym ,tag))
124 (open-html-tag ,tag-sym ,@attributes)
125 (pprint-indent :block 2 *html-stream*)
126 (pprint-newline :linear *html-stream*)
127 (unwind-protect
128 (progn ,@body)
129 (pprint-indent :block 0 *html-stream*)
130 (pprint-newline :linear *html-stream*)
131 (close-html-tag ,tag-sym)))))))
132
133 (defmacro with-html-inline ((tag &rest attributes) &body body)
134 (let ((tag-sym (gensym "TAG-")))
135 `(let ((,tag-sym ,tag))
136 (open-html-tag ,tag-sym ,@attributes)
137 (unwind-protect
138 (progn ,@body)
139 (close-html-tag ,tag-sym)))))
140
141 (defmacro write-html-tag (tag-name &rest attributes)
142 "Writes a bodiless html tag. Uses the XHTML <.../> syntax."
143 `(unless *suppress-html-tags*
144 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix "/>")
145 (write-string ,(string tag-name) *html-stream*)
146 (write-html-attributes ,@attributes))))
147
148 (defmacro write-html-tag* (tag-list)
149 "Writes a bodiless html tag. Uses the XHTML <.../> syntax. The argument evaluates to an
150 arglist for WRITE-HTML-TAG."
151 (let ((tag-sym (gensym "TAG-")))
152 `(unless *suppress-html-tags*
153 (let ((,tag-sym ,tag-list))
154 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix "/>")
155 (write-string (string (first ,tag-sym)) *html-stream*)
156 (apply #'write-html-attributes (rest ,tag-sym)))))))
157
158 (defmacro write-html-entity (form)
159 (let ((val-sym (gensym "VAL-")))
160 `(let ((,val-sym ,form))
161 (write-char #\& *html-stream*)
162 (write-string ,val-sym *html-stream*)
163 (write-char #\; *html-stream*))))
164
165 (eval-when (:execute :compile-toplevel :load-toplevel)
166 (unless (boundp '+escape-alist+)
167 (defconstant +escape-alist+
168 '((#\& . "amp")
169 (#\< . "lt")
170 (#\> . "gt")
171 (#\" . "quot")))))
172
173 (defmacro write-html-char (form)
174 (let ((val-sym (gensym "VAL-")))
175 `(let ((,val-sym ,form))
176 (cond
177 ,@(mapcar (lambda (pair)
178 (destructuring-bind (char . escape) pair
179 `((eql ,val-sym ,char) (write-html-entity ,escape))))
180 +escape-alist+)
181 (t (write-char ,val-sym *html-stream*))))))
182
183 ;;;
184 ;;; Abstraction of the way HTML will be generated
185 ;;;
186
187 (defmacro define-html-conversion (type (element &optional (html-class 'html-output)) &body body)
188 `(defmethod convert ((,element ,type) (.output. ,html-class))
189 (flet ((convert (&optional (element (contents ,element)))
190 (convert element .output.))
191 (convert-to-text (element)
192 (let ((*suppress-html-tags* t))
193 (convert element .output.))))
194 ,@body)))
195
196 ;;;
197 ;;; The actual converters
198 ;;;
199
200 ;;; The toplevel conversion routines, so we'll use a full defmethod and set up various
201 ;;; dynamic variables to reasonable defaults
202
203 (defmethod convert ((input toplevel-element) (output html-output))
204 (with-accessors ((title title)
205 (author author)
206 (date date)
207 (copyright copyright)) input
208 (flet ((convert-to-string (element)
209 (with-output-to-string (*html-stream*)
210 (let ((*suppress-html-tags* t))
211 (convert element output)))))
212 (let ((*html-head-elements* *html-head-elements*)
213 (*document-title* title))
214 (when author
215 (push (list :META :NAME "Author" :CONTENT (convert-to-string author))
216 *html-head-elements*))
217 (when date
218 (push (list :META :NAME "Date" :CONTENT (convert-to-string date))
219 *html-head-elements*))
220 (when copyright
221 (push (list :META :NAME "Copyright" :CONTENT (convert-to-string copyright))
222 *html-head-elements*))
223 #+nil (engine-specific-option input 'html-output 'head-elements)
224 (call-next-method)))))
225
226 (defmethod convert ((input toplevel-subelement) (output html-output))
227 (flet ((convert-to-text (element)
228 (let ((*suppress-html-tags* t))
229 (convert element output))))
230 (with-next-output-stream (*html-stream* output)
231 (with-html-block+ (0 :mandatory :HTML)
232 (with-html-block+ (1 :mandatory :HEAD)
233 (with-html-block (:TITLE)
234 (convert-to-text *document-title*))
235 (dolist (element *html-head-elements*)
236 (pprint-newline :linear *html-stream*)
237 (write-html-tag* element)))
238 (with-html-block+ (0 :mandatory :BODY)
239 (convert (contents input) output))))))
240
241 ;;; The simpler converters
242
243 (define-html-conversion section-header (input)
244 (let* ((header-level (header-level input))
245 (header-tag (case header-level
246 (1 :H1)
247 (2 :H2)
248 (3 :H3)
249 (4 :H4)
250 (5 :H5)
251 (6 :H6)
252 (t (error "Maximum section nesting level exceeded for HTML.")))))
253
254 (when (< header-level 3) (pprint-newline :mandatory *html-stream*))
255 (pprint-indent :block (1- (header-level input)) *html-stream*)
256 (pprint-newline :mandatory *html-stream*)
257 (with-html-block (header-tag)
258 (convert))
259 (pprint-indent :block (header-level input) *html-stream*)
260 (pprint-newline :linear *html-stream*)))
261
262 (define-html-conversion paragraph (input)
263 (with-html-block (:P)
264 (convert)))
265
266 (define-html-conversion block-quotation (input)
267 (with-html-block (:BLOCKQUOTE)
268 (convert)))
269
270 (define-html-conversion preformatted-paragraph (input)
271 (with-html-block+ (0 nil :PRE)
272 (let ((*suppress-html-wrapping* t))
273 (convert))))
274
275 (define-html-conversion bold (input)
276 (with-html-inline (:B)
277 (convert)))
278
279 (define-html-conversion italic (input)
280 (with-html-inline (:I)
281 (convert)))
282
283 (define-html-conversion discretionary-hyphen (input)
284 (write-html-entity "shy"))
285
286 (define-html-conversion discretionary-break (input)
287 (convert (no-break-elements input)))
288
289 (define-html-conversion character (input)
290 (write-html-char input))
291
292 (define-html-conversion (eql #\space) (input)
293 (write-html-char #\space)
294 (pprint-newline :fill *html-stream*))
295
296 (define-html-conversion (eql #\newline) (input)
297 (if *suppress-html-wrapping*
298 (write-html-char #\newline)
299 (progn
300 (pprint-newline :miser *html-stream*)
301 (write-html-tag :BR)
302 (pprint-newline :linear *html-stream*))))
303
304 (define-html-conversion sequence (input)
305 (map 'nil (lambda (item) (convert item))
306 input))

  ViewVC Help
Powered by ViewVC 1.1.5