/[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.2 - (hide annotations)
Sun Feb 15 05:01:46 2004 UTC (10 years, 2 months ago) by rjain
Branch: MAIN
Changes since 1.1: +15 -2 lines
additions and tweaks for the defdoc-generated defdoc website:
elements that are abbreviations for more complex sequences of elements
hyperlink document element
small-caps style element
subtitle in documents
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     (write " - " :stream *html-stream*)
239     (convert-to-text *document-subtitle*))
240 rjain 1.1 (dolist (element *html-head-elements*)
241     (pprint-newline :linear *html-stream*)
242     (write-html-tag* element)))
243     (with-html-block+ (0 :mandatory :BODY)
244     (convert (contents input) output))))))
245    
246     ;;; The simpler converters
247    
248     (define-html-conversion section-header (input)
249     (let* ((header-level (header-level input))
250     (header-tag (case header-level
251     (1 :H1)
252     (2 :H2)
253     (3 :H3)
254     (4 :H4)
255     (5 :H5)
256     (6 :H6)
257     (t (error "Maximum section nesting level exceeded for HTML.")))))
258    
259     (when (< header-level 3) (pprint-newline :mandatory *html-stream*))
260     (pprint-indent :block (1- (header-level input)) *html-stream*)
261     (pprint-newline :mandatory *html-stream*)
262     (with-html-block (header-tag)
263     (convert))
264     (pprint-indent :block (header-level input) *html-stream*)
265     (pprint-newline :linear *html-stream*)))
266    
267     (define-html-conversion paragraph (input)
268     (with-html-block (:P)
269     (convert)))
270    
271     (define-html-conversion block-quotation (input)
272     (with-html-block (:BLOCKQUOTE)
273     (convert)))
274    
275     (define-html-conversion preformatted-paragraph (input)
276     (with-html-block+ (0 nil :PRE)
277     (let ((*suppress-html-wrapping* t))
278     (convert))))
279    
280     (define-html-conversion bold (input)
281     (with-html-inline (:B)
282     (convert)))
283    
284     (define-html-conversion italic (input)
285     (with-html-inline (:I)
286 rjain 1.2 (convert)))
287    
288     (define-html-conversion small-caps (input)
289     (with-html-inline (:SPAN :style "font-variant: small-caps")
290     (convert)))
291    
292     (define-html-conversion link (input)
293     (with-html-inline (:A :href (url input))
294 rjain 1.1 (convert)))
295    
296     (define-html-conversion discretionary-hyphen (input)
297     (write-html-entity "shy"))
298    
299     (define-html-conversion discretionary-break (input)
300     (convert (no-break-elements input)))
301    
302     (define-html-conversion character (input)
303     (write-html-char input))
304    
305     (define-html-conversion (eql #\space) (input)
306     (write-html-char #\space)
307     (pprint-newline :fill *html-stream*))
308    
309     (define-html-conversion (eql #\newline) (input)
310     (if *suppress-html-wrapping*
311     (write-html-char #\newline)
312     (progn
313     (pprint-newline :miser *html-stream*)
314     (write-html-tag :BR)
315     (pprint-newline :linear *html-stream*))))
316    
317     (define-html-conversion sequence (input)
318     (map 'nil (lambda (item) (convert item))
319     input))

  ViewVC Help
Powered by ViewVC 1.1.5