/[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.5 - (hide annotations)
Sun Feb 15 05:35:04 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
Changes since 1.4: +3 -2 lines
oops, don't output "-" when there is no subtitle
1 rjain 1.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 rjain 1.2 (defvar *document-subtitle*)
26 rjain 1.1
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 rjain 1.2 (subtitle subtitle)
207 rjain 1.1 (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 rjain 1.2 (*document-title* title)
216     (*document-subtitle* subtitle))
217 rjain 1.1 (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 rjain 1.2 (convert-to-text *document-title*)
238 rjain 1.5 (when *document-subtitle*
239     (write-string " - " *html-stream*)
240     (convert-to-text *document-subtitle*)))
241 rjain 1.1 (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 preformatted-paragraph (input)
277     (with-html-block+ (0 nil :PRE)
278     (let ((*suppress-html-wrapping* t))
279     (convert))))
280    
281     (define-html-conversion bold (input)
282     (with-html-inline (:B)
283     (convert)))
284    
285     (define-html-conversion italic (input)
286     (with-html-inline (:I)
287 rjain 1.2 (convert)))
288    
289     (define-html-conversion small-caps (input)
290     (with-html-inline (:SPAN :style "font-variant: small-caps")
291     (convert)))
292    
293     (define-html-conversion link (input)
294     (with-html-inline (:A :href (url input))
295 rjain 1.1 (convert)))
296    
297     (define-html-conversion discretionary-hyphen (input)
298     (write-html-entity "shy"))
299    
300     (define-html-conversion discretionary-break (input)
301     (convert (no-break-elements input)))
302    
303     (define-html-conversion character (input)
304     (write-html-char input))
305    
306     (define-html-conversion (eql #\space) (input)
307     (write-html-char #\space)
308     (pprint-newline :fill *html-stream*))
309    
310     (define-html-conversion (eql #\newline) (input)
311     (if *suppress-html-wrapping*
312     (write-html-char #\newline)
313     (progn
314     (pprint-newline :miser *html-stream*)
315     (write-html-tag :BR)
316     (pprint-newline :linear *html-stream*))))
317    
318     (define-html-conversion sequence (input)
319     (map 'nil (lambda (item) (convert item))
320     input))

  ViewVC Help
Powered by ViewVC 1.1.5