/[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.6 - (show annotations)
Thu Oct 11 16:20:10 2007 UTC (6 years, 6 months ago) by rjain
Branch: MAIN
CVS Tags: HEAD
Changes since 1.5: +6 -0 lines
Add conversion for itemized lists
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 (defvar *document-subtitle*)
26
27 (defvar *html-stream*)
28
29 (defmacro pprint-newline (kind stream)
30 `(unless *suppress-html-wrapping*
31 (cl:pprint-newline ,kind ,stream)))
32
33 (declaim (inline %write-html-attributes))
34 (defun %write-html-attributes (&rest attributes)
35 (loop
36 for (key val . rest) on attributes by #'cddr
37 do (when val
38 (if (eq val t) ;; just print the attribute with no value
39 (write-string (string key) *html-stream*)
40 (progn
41 (write-string (string key) *html-stream*)
42 (write-char #\= *html-stream*)
43 (typecase val
44 (integer (write val :stream *html-stream*))
45 (symbol (write-string (symbol-name val) *html-stream*))
46 (string (write-char #\" *html-stream*)
47 (write-string val *html-stream*)
48 (write-char #\" *html-stream*)))))
49 (when rest
50 (write-char #\space *html-stream*)
51 (pprint-newline :fill *html-stream*)))))
52
53 (defun write-html-attributes (&rest attributes)
54 (when attributes
55 (write-char #\space *html-stream*)
56 (pprint-indent :current 0 *html-stream*)
57 (pprint-newline :miser *html-stream*)
58 #+nil(apply #'%write-html-attributes
59 (engine-specific-option element 'html-engine 'html-attributes))
60 (apply #'%write-html-attributes attributes)))
61
62 (define-compiler-macro write-html-attributes (&whole whole &rest attributes)
63 (when attributes
64 (if (eq (car whole) 'write-html-attributes)
65 `(progn
66 (write-char #\space *html-stream*)
67 (pprint-indent :current 0 *html-stream*)
68 (pprint-newline :miser *html-stream*)
69 #+nil(apply #'%write-html-attributes
70 (engine-specific-option element 'html-engine 'html-attributes))
71 ,@(loop
72 with val-sym = (gensym "VAL-")
73 for (key val . rest) on attributes by #'cddr
74 collect `(let ((,val-sym ,val))
75 (when ,val-sym
76 (if (eq ,val-sym t) ;; just print the attribute with no value
77 (write-string ,(string key) *html-stream*)
78 (progn
79 (write-string ,(string key) *html-stream*)
80 (write-char #\= *html-stream*)
81 (typecase ,val-sym
82 (integer (write ,val-sym :stream *html-stream*))
83 (symbol (write-string (symbol-name ,val-sym)
84 *html-stream*))
85 (string (write-char #\" *html-stream*)
86 (write-string ,val-sym *html-stream*)
87 (write-char #\" *html-stream*)))))
88 ,@(when rest '((write-char #\space *html-stream*)
89 (pprint-newline :fill *html-stream*)))))))
90 whole)))
91
92 (defmacro open-html-tag (tag-name &rest attributes)
93 `(unless *suppress-html-tags*
94 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix ">")
95 (write-string (string ,tag-name) *html-stream*)
96 (write-html-attributes ,@attributes))))
97
98 (defmacro close-html-tag (tag-name)
99 `(unless *suppress-html-tags*
100 (write-string "</" *html-stream*)
101 (write-string (string ,tag-name) *html-stream*)
102 (write-char #\> *html-stream*)))
103
104 (defmacro with-html-block+ ((indent break-style tag &rest attributes) &body body)
105 (let ((tag-sym (gensym "TAG-")))
106 `(progn
107 (pprint-newline :linear *html-stream*)
108 (pprint-logical-block (*html-stream* nil)
109 (let ((,tag-sym ,tag))
110 (open-html-tag ,tag-sym ,@attributes)
111 (pprint-indent :block ,indent *html-stream*)
112 ,(and break-style `(pprint-newline ,break-style *html-stream*))
113 (unwind-protect
114 (progn ,@body)
115 (pprint-indent :block 0 *html-stream*)
116 ,(and break-style `(pprint-newline ,break-style *html-stream*))
117 (close-html-tag ,tag-sym)))))))
118
119 (defmacro with-html-block ((tag &rest attributes) &body body)
120 (let ((tag-sym (gensym "TAG-")))
121 `(progn
122 (pprint-newline :linear *html-stream*)
123 (pprint-logical-block (*html-stream* nil)
124 (let ((,tag-sym ,tag))
125 (open-html-tag ,tag-sym ,@attributes)
126 (pprint-indent :block 2 *html-stream*)
127 (pprint-newline :linear *html-stream*)
128 (unwind-protect
129 (progn ,@body)
130 (pprint-indent :block 0 *html-stream*)
131 (pprint-newline :linear *html-stream*)
132 (close-html-tag ,tag-sym)))))))
133
134 (defmacro with-html-inline ((tag &rest attributes) &body body)
135 (let ((tag-sym (gensym "TAG-")))
136 `(let ((,tag-sym ,tag))
137 (open-html-tag ,tag-sym ,@attributes)
138 (unwind-protect
139 (progn ,@body)
140 (close-html-tag ,tag-sym)))))
141
142 (defmacro write-html-tag (tag-name &rest attributes)
143 "Writes a bodiless html tag. Uses the XHTML <.../> syntax."
144 `(unless *suppress-html-tags*
145 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix "/>")
146 (write-string ,(string tag-name) *html-stream*)
147 (write-html-attributes ,@attributes))))
148
149 (defmacro write-html-tag* (tag-list)
150 "Writes a bodiless html tag. Uses the XHTML <.../> syntax. The argument evaluates to an
151 arglist for WRITE-HTML-TAG."
152 (let ((tag-sym (gensym "TAG-")))
153 `(unless *suppress-html-tags*
154 (let ((,tag-sym ,tag-list))
155 (pprint-logical-block (*html-stream* nil :prefix "<" :suffix "/>")
156 (write-string (string (first ,tag-sym)) *html-stream*)
157 (apply #'write-html-attributes (rest ,tag-sym)))))))
158
159 (defmacro write-html-entity (form)
160 (let ((val-sym (gensym "VAL-")))
161 `(let ((,val-sym ,form))
162 (write-char #\& *html-stream*)
163 (write-string ,val-sym *html-stream*)
164 (write-char #\; *html-stream*))))
165
166 (eval-when (:execute :compile-toplevel :load-toplevel)
167 (unless (boundp '+escape-alist+)
168 (defconstant +escape-alist+
169 '((#\& . "amp")
170 (#\< . "lt")
171 (#\> . "gt")
172 (#\" . "quot")))))
173
174 (defmacro write-html-char (form)
175 (let ((val-sym (gensym "VAL-")))
176 `(let ((,val-sym ,form))
177 (cond
178 ,@(mapcar (lambda (pair)
179 (destructuring-bind (char . escape) pair
180 `((eql ,val-sym ,char) (write-html-entity ,escape))))
181 +escape-alist+)
182 (t (write-char ,val-sym *html-stream*))))))
183
184 ;;;
185 ;;; Abstraction of the way HTML will be generated
186 ;;;
187
188 (defmacro define-html-conversion (type (element &optional (html-class 'html-output)) &body body)
189 `(defmethod convert ((,element ,type) (.output. ,html-class))
190 (flet ((convert (&optional (element (contents ,element)))
191 (convert element .output.))
192 (convert-to-text (element)
193 (let ((*suppress-html-tags* t))
194 (convert element .output.))))
195 ,@body)))
196
197 ;;;
198 ;;; The actual converters
199 ;;;
200
201 ;;; The toplevel conversion routines, so we'll use a full defmethod and set up various
202 ;;; dynamic variables to reasonable defaults
203
204 (defmethod convert ((input toplevel-element) (output html-output))
205 (with-accessors ((title title)
206 (subtitle subtitle)
207 (author author)
208 (date date)
209 (copyright copyright)) input
210 (flet ((convert-to-string (element)
211 (with-output-to-string (*html-stream*)
212 (let ((*suppress-html-tags* t))
213 (convert element output)))))
214 (let ((*html-head-elements* *html-head-elements*)
215 (*document-title* title)
216 (*document-subtitle* subtitle))
217 (when author
218 (push (list :META :NAME "Author" :CONTENT (convert-to-string author))
219 *html-head-elements*))
220 (when date
221 (push (list :META :NAME "Date" :CONTENT (convert-to-string date))
222 *html-head-elements*))
223 (when copyright
224 (push (list :META :NAME "Copyright" :CONTENT (convert-to-string copyright))
225 *html-head-elements*))
226 #+nil (engine-specific-option input 'html-output 'head-elements)
227 (call-next-method)))))
228
229 (defmethod convert ((input toplevel-subelement) (output html-output))
230 (flet ((convert-to-text (element)
231 (let ((*suppress-html-tags* t))
232 (convert element output))))
233 (with-next-output-stream (*html-stream* output)
234 (with-html-block+ (0 :mandatory :HTML)
235 (with-html-block+ (1 :mandatory :HEAD)
236 (with-html-block (:TITLE)
237 (convert-to-text *document-title*)
238 (when *document-subtitle*
239 (write-string " - " *html-stream*)
240 (convert-to-text *document-subtitle*)))
241 (dolist (element *html-head-elements*)
242 (pprint-newline :linear *html-stream*)
243 (write-html-tag* element)))
244 (with-html-block+ (0 :mandatory :BODY)
245 (convert (contents input) output))))))
246
247 ;;; The simpler converters
248
249 (define-html-conversion section-header (input)
250 (let* ((header-level (header-level input))
251 (header-tag (case header-level
252 (1 :H1)
253 (2 :H2)
254 (3 :H3)
255 (4 :H4)
256 (5 :H5)
257 (6 :H6)
258 (t (error "Maximum section nesting level exceeded for HTML.")))))
259
260 (when (< header-level 3) (pprint-newline :mandatory *html-stream*))
261 (pprint-indent :block (1- (header-level input)) *html-stream*)
262 (pprint-newline :mandatory *html-stream*)
263 (with-html-block (header-tag)
264 (convert))
265 (pprint-indent :block (header-level input) *html-stream*)
266 (pprint-newline :linear *html-stream*)))
267
268 (define-html-conversion paragraph (input)
269 (with-html-block (:P)
270 (convert)))
271
272 (define-html-conversion block-quotation (input)
273 (with-html-block (:BLOCKQUOTE)
274 (convert)))
275
276 (define-html-conversion itemized-list (input)
277 (with-html-block (:UL)
278 (dolist (element (contents input))
279 (with-html-block (:LI)
280 (convert element)))))
281
282 (define-html-conversion preformatted-paragraph (input)
283 (with-html-block+ (0 nil :PRE)
284 (let ((*suppress-html-wrapping* t))
285 (convert))))
286
287 (define-html-conversion bold (input)
288 (with-html-inline (:B)
289 (convert)))
290
291 (define-html-conversion italic (input)
292 (with-html-inline (:I)
293 (convert)))
294
295 (define-html-conversion small-caps (input)
296 (with-html-inline (:SPAN :style "font-variant: small-caps")
297 (convert)))
298
299 (define-html-conversion link (input)
300 (with-html-inline (:A :href (url input))
301 (convert)))
302
303 (define-html-conversion discretionary-hyphen (input)
304 (write-html-entity "shy"))
305
306 (define-html-conversion discretionary-break (input)
307 (convert (no-break-elements input)))
308
309 (define-html-conversion character (input)
310 (write-html-char input))
311
312 (define-html-conversion (eql #\space) (input)
313 (write-html-char #\space)
314 (pprint-newline :fill *html-stream*))
315
316 (define-html-conversion (eql #\newline) (input)
317 (if *suppress-html-wrapping*
318 (write-html-char #\newline)
319 (progn
320 (pprint-newline :miser *html-stream*)
321 (write-html-tag :BR)
322 (pprint-newline :linear *html-stream*))))
323
324 (define-html-conversion sequence (input)
325 (map 'nil (lambda (item) (convert item))
326 input))

  ViewVC Help
Powered by ViewVC 1.1.5