/[cldoc]/cldoc/src/html.lisp
ViewVC logotype

Contents of /cldoc/src/html.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sun Jan 8 22:18:26 2006 UTC (8 years, 3 months ago) by ihatchondo
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +3 -4 lines
package def updated and cosmetic changes.
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLUDG; -*-
2 ;;; $Id: html.lisp,v 1.11 2006/01/08 22:18:26 ihatchondo Exp $
3 ;;; ---------------------------------------------------------------------------
4 ;;; Title: Common Lisp Universal Documentation Generator: HTML driver
5 ;;; Created: 2005 10 23 2:30
6 ;;; Author: Iban Hatchondo <hatchond@yahoo.fr>
7 ;;; ---------------------------------------------------------------------------
8 ;;; (c) copyright 2005 by Iban Hatchondo
9
10 ;;; The authors grant you the rights to distribute
11 ;;; and use this software as governed by the terms
12 ;;; of the Lisp Lesser GNU Public License
13 ;;; (http://opensource.franz.com/preamble.html),
14 ;;; known as the LLGPL.
15
16 ;;; XHTML 1.0 Strict CLUDG driver.
17
18 (in-package :cludg)
19
20 ;;;
21
22 (defconstant +HTML-DOCTYPE+
23 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
24 \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
25
26 (defconstant +default-charset+ "ISO-8859-1"
27 "Default charset is: ISO-8859-1")
28
29 ;; Associate "html" extension with the :html output format.
30 (register-output-type :html "html")
31
32 (defclass html (driver)
33 ((string-parser-initargs :type list :initarg :string-parser-initargs)
34 (doc-formater
35 :type function
36 :initarg :doc-formater
37 :initform #'format-doc
38 :reader doc-formater)
39 (filter
40 :type (or null function)
41 :initarg :filter
42 :initform #'filter-defmethod-with-defgeneric
43 :reader filter)
44 (sort-predicate
45 :type (or null function)
46 :initarg :sort-predicate
47 :initform #'default-sort-predicate
48 :reader sort-predicate)
49 (css-pathname
50 :type string
51 :initarg :css-pathname
52 :initform (make-default-css-namestring)
53 :reader css-pathname)
54 (charset
55 :type string
56 :initarg :charset
57 :initform +default-charset+
58 :reader charset)
59 (copy-css-into-output-dir
60 :type boolean
61 :initform t
62 :initarg :copy-css-into-output-dir)
63 (toc-title
64 :type (or null string)
65 :initarg :table-of-contents-title
66 :initform nil
67 :reader toc-title))
68 (:documentation "CLDOC XHTML 1.0 Strict driver.
69
70 Use the following options with extract-documentation to customize the
71 produced output:
72 - :toc-title (or null string): a string that will be used as a title in
73 the table of contents. If not given then the toc title will be: Table
74 of Contents.
75 - :doc-formater (function): a designator for a function of two arguments.
76 Its first arguments will be an html-driver instance and its second
77 argument will be a list of string that represents each lines of the
78 original documentation string. It is expected that this function will
79 output the strings, using the html machinery.
80 The default doc-formater has some simple DWIM (Do What I Mean)
81 capabilities. It recognizes both indent and empty-line paragraph breaks,
82 bulleted lists, code sample, hyper link and sections (like in the
83 Hyperspec). The default {defun format-doc} function delegates the
84 DWIM capabilities to the {defclass doctree} class.
85 - :filter (or null function): a designator for a function of one argument.
86 Its argument will be a symbol-descriptor object. The symbol-descriptor
87 will be outputted if and only if this function returns NIL.
88 - :sort-predicate (or null function): a designator for a function of two
89 arguments that returns a generalized boolean.
90 Predicate should return true if and only if the first argument is
91 strictly less than the second (in some appropriate sense). If the first
92 argument is greater than or equal to the second (in the appropriate
93 sense), then the predicate should return false.
94 - :css-pathname (string): a string pathname designator for the css file
95 to use in the generated documentation. The default one is the cludg.css
96 file delivered with this driver.
97 - :charset (string): a string designator for the charset of the generated
98 documentation. The default one is: +default-charset+
99 - :copy-css-into-output-dir (boolean): if you want the css file to be
100 copied in the destination directory. This will allow your created
101 documentation to be completely independent of your hard drive
102 hierarchy. Otherwise relative reference to the given pathname will be
103 generated. Default is set to T. And if :css-pathname is not specified
104 the file delivered with CLDOC will simply be copied into the output
105 directory (see :css-pathname).
106
107 All the options supported by the {defclass doctree} class are supported
108 when passed to the {defgeneric extract-documentation} method.
109
110 To localise the automatic documentation , if your documentation strings
111 are not in english, the default generation language, you have to modify
112 the following variables:
113 - *class-inheritence*
114 - *condition-inheritence*
115 - *struct-inheritence*
116 - *slot-reader-control-string*
117 - *slot-writer-control-string*
118 - *slot-accessor-control-string*
119 - *copier-control-string*
120 - *predicate-control-string*
121 - *printer-control-string*
122 - *constructor-control-string*"))
123
124 (defun get-initargs
125 (initargs &optional (default-initargs
126 '(:copy-css-into-output-dir :filter :sort-predicate
127 :charset :table-of-contents-title :doc-formater
128 :css-pathname)))
129 (loop with foo = (gensym)
130 for initarg in default-initargs
131 for value = (getf initargs initarg foo)
132 unless (eq value foo) do (remf initargs initarg)
133 and collect initarg and collect value))
134
135 (defmethod extract-documentation ((driver (eql 'html)) dest-dir
136 (system asdf:system)
137 &rest initargs &key &allow-other-keys)
138 (unless (getf initargs :path-prefix)
139 (setf (getf initargs :path-prefix)
140 (namestring (asdf:component-relative-pathname system))))
141 (let ((files (get-asdf-system-files system)))
142 (apply #'extract-documentation driver dest-dir files initargs)))
143
144 (defmethod extract-documentation ((driver (eql 'html)) dest-dir filenames
145 &rest initargs &key &allow-other-keys)
146 (declare (ignorable driver))
147 (let ((pp (getf initargs :path-prefix)))
148 (remf initargs :path-prefix)
149 (let ((args (get-initargs initargs)))
150 (make-html-doc
151 (apply #'make-instance 'html :string-parser-initargs initargs args)
152 filenames
153 :path-prefix (or pp (directory-namestring (or *load-truename* ".")))
154 :dest-dir (or dest-dir ".")))))
155
156 ;;;
157
158 (deftype card8 () `(unsigned-byte 8))
159
160 (defmacro with-gensym (symbols &body body)
161 `(let ,(loop for s in symbols collect `(,s (gensym)))
162 ,@body))
163
164 (defun copy-css (html-driver &key dest-dir)
165 (with-slots (css-pathname copy-css-into-output-dir) html-driver
166 (if copy-css-into-output-dir
167 (let* ((name (file-namestring (truename css-pathname)))
168 (new-css-path (merge-pathnames name dest-dir)))
169 (prog1 (namestring new-css-path)
170 (unless (probe-file new-css-path)
171 (with-open-file
172 (os new-css-path :direction :output :element-type 'card8)
173 (write-sequence
174 (with-open-file (is css-pathname :element-type 'card8)
175 (loop with offset of-type fixnum = 0
176 with size of-type fixnum = (file-length is)
177 with vec = (make-array size :element-type 'card8)
178 while (< offset size)
179 do (setf offset (read-sequence vec is :start offset))
180 finally (return vec)))
181 os)))))
182 css-pathname)))
183
184 (defun default-filter (desc)
185 "Returns true if the given symbol-descriptor is not an external symbol
186 of its package or if is a defmethod descriptor for which a defgeneric
187 descriptor exists."
188 (when (typep desc 'defpackage-descriptor)
189 (return-from default-filter nil))
190 (multiple-value-bind (sym status)
191 (let* ((name (standard-io-name (name desc)))
192 (space (position #\Space name :test #'char=)))
193 (when space
194 (setf name (subseq name (1+ space) (1- (length name)))))
195 (find-symbol name (find-package-caseless (dpackage desc))))
196 (declare (ignore sym))
197 (if (eq status :external) (filter-defmethod-with-defgeneric desc) T)))
198
199 (defun filter-defmethod-with-defgeneric (desc)
200 "Returns true if the given symbol-descriptor is a defmethod descriptor
201 and thus if the specified defmethod has a defgeneric."
202 (when (typep desc 'defmethod-descriptor)
203 (lookup-meta-descriptor (name desc) 'defgeneric-descriptor)))
204
205 (defun make-default-css-namestring ()
206 (namestring
207 (merge-pathnames
208 "cludg.css"
209 (make-pathname :defaults (directory-namestring *cludg-directory*)))))
210
211 (defun symbol-descriptor-weight (sym-desc-instance)
212 "Returns the weight, a valuation, used to sort the final documentation."
213 (typecase sym-desc-instance
214 ;(in-package-form -1)
215 (defpackage-descriptor 0)
216 (defclass-descriptor 1)
217 (define-condition-descriptor 2)
218 (defstruct-descriptor 3)
219 (deftype-descriptor 4)
220 (defconstant-descriptor 5)
221 (param-descriptor 6)
222 (defgeneric-descriptor 7)
223 (defmethod-descriptor 8)
224 (defun-descriptor 9)
225 (defsetf-descriptor 10)
226 (defmacro-descriptor 11)
227 (t 12)))
228
229 (defun desc-sort (descs predicate &key key)
230 "Sort such as stable-sort but non destructively the given list of descs."
231 (if (null predicate) descs
232 (stable-sort (copy-list descs) predicate :key key)))
233
234 (defun default-sort-predicate (desc1 desc2)
235 (< (symbol-descriptor-weight desc1) (symbol-descriptor-weight desc2)))
236
237 (defun next (list index dest-dir &optional prefix)
238 "Returns the relative pathanme to the next (aka 1+ index) element of list."
239 (declare (type list list))
240 (declare (type fixnum index))
241 (when (< index (1- (length list)))
242 (flet ((mkout (file) (make-output-pathname file dest-dir :html prefix)))
243 (make-pathname-relative
244 :from (mkout (car (elt list index)))
245 :to (mkout (car (elt list (1+ index))))))))
246
247 (defun prev (list index dest-dir &optional prefix)
248 "Returns the relative pathanme to previous (aka 1- index) element of list."
249 (declare (type list list))
250 (declare (type fixnum index))
251 (unless (zerop index)
252 (flet ((mkout (file) (make-output-pathname file dest-dir :html prefix)))
253 (make-pathname-relative
254 :from (mkout (car (elt list index)))
255 :to (mkout (car (elt list (1- index))))))))
256
257 (defun alphabetical-order (desc1 desc2)
258 "Returns true if the name of the first descriptor is lexicographicaly
259 inferior to the name of the second descriptor."
260 (flet ((get-name (desc)
261 (let ((name (name desc)))
262 (if (starts-with name "(") (subseq name 1) name))))
263 (let ((name1 (get-name desc1))
264 (name2 (get-name desc2)))
265 (if (alpha-char-p (char name1 0))
266 (if (alpha-char-p (char name2 0)) (string-lessp name1 name2) T)
267 (unless (alpha-char-p (char name2 0))
268 (string-lessp name1 name2))))))
269
270 ;;;
271 ;;; Macros for HTML writing.
272 ;;;
273
274 (defvar *html-output-stream* nil "An output stream to write HTML forms.")
275
276 (defmacro with-html-output ((output-stream) &body body)
277 "Binds *html-output-stream* to the output-stream in order to use the
278 html-write, with-tag, htmlify-doc and with-html-description macros
279 without their output-stream optional argument."
280 `(let ((*html-output-stream* ,output-stream))
281 ,@body))
282
283 (defmacro html-write (control-string &rest args)
284 "Produces formatted output by outputting the characters of control-string
285 and observing that a tilde introduces a directive. Most directives use
286 one or more elements of args to create their output."
287 `(format *html-output-stream* ,control-string ,@args))
288
289 (defmacro with-tag
290 ((tagname (&rest attributes) &optional (stream '*html-output-stream*))
291 &body body)
292 "Writes the desired tag and its attributes to the given stream or the
293 one binded on *html-output-stream*."
294 (with-gensym (os)
295 `(let ((,os ,stream))
296 (format ,os "<~a~{~^ ~a=\"~a\"~}~:[~;/~]>~%"
297 ,tagname (list ,@attributes) ,(zerop (length body)))
298 (prog1 (progn ,@body)
299 ,@(unless (zerop (length body))
300 `((format ,os "</~a>~%" ,tagname)))))))
301
302 (defmacro with-html-page
303 ((os &key csshref content-type head-title nav-name index prev next)
304 &body body)
305 "Binds *html-output-stream* to os as if binded by with-html-output and
306 executes the body in inside the BODY tag. A simple implementation can be:
307 ;;; (with-tag (:html ())
308 ;;; (with-tag (:head ()) (do-header))
309 ;;; (with-tag (:body ()) ,@body))"
310 `(with-html-output (,os)
311 (html-write "~a~2%" +HTML-DOCTYPE+)
312 (with-tag (:html ())
313 (with-tag (:head ())
314 (with-tag (:link (:rel "Stylesheet" :type "text/css" :href ,csshref)))
315 (with-tag (:meta (:http-equiv "Content-Type" :content ,content-type)))
316 (with-tag (:title ()) (html-write ,head-title)))
317 (with-tag (:body ())
318 (make-navbar :name ,nav-name :index ,index :prev ,prev :next ,next)
319 ,@body
320 (make-footer)))))
321
322 (defun htmlify-doc (desc &key (doc-string (doc desc)) (purge-p t) html-driver)
323 "Presents the given doc-string according to our html template.
324 - doc-string (string): the documentation string to write.
325 - purge-p (boolean): If T the documentation string will be purged of
326 potentially dangerous character for HTML.
327 - html-driver (driver): the html-driver to use."
328 (when (and doc-string (string/= doc-string ""))
329 (with-tag (:div (:class "doc-body"))
330 (funcall (doc-formater html-driver)
331 desc
332 html-driver
333 (mapcar #'(lambda (s) (if purge-p (purge-string-for-html s) s))
334 (grok-new-lines doc-string))))))
335
336 (defmacro with-html-description
337 ((&key (divclass "defun") name arg-list type anchor) &body body)
338 "Presents lisp forms according to our html documentation template."
339 (with-gensym (hanchor args)
340 `(with-tag (:div ,(when divclass `(:class ,divclass)))
341 (with-tag (:div ,(when divclass `(:class "defunsignatures")))
342 (let ((,hanchor ,anchor))
343 (when ,hanchor (with-tag (:a (:id ,hanchor)) "")))
344 (with-tag (:table (:cellpadding 0 :cellspacing 0 :width "100%"))
345 (with-tag (:colgroup (:span 3))
346 (with-tag (:col (:width "0*")))
347 (with-tag (:col (:width "1*")))
348 (with-tag (:col (:width "0*"))))
349 (with-tag (:tbody ())
350 (with-tag (:tr ())
351 (with-tag (:td (:class "symbol-name"))
352 (html-write "~a&nbsp;&nbsp;" ,name))
353 (with-tag (:td (:class "lambda-list"))
354 (let ((,args ,arg-list))
355 (when ,args (html-write "~a" ,args))))
356 (with-tag (:td (:class "symbol-type"))
357 (html-write "&nbsp;[~@(~a~)]" ,type))))))
358 ,@body)))
359
360 (defun make-footer ()
361 "Appends CLDOC link and generation date."
362 (with-tag (:div (:class "cludg-footer"))
363 (html-write "Generated by&nbsp;")
364 (with-tag (:a (:href "mailto:ihatchondo@common-lisp.net" :lang "en"))
365 (html-write "CLDOC"))
366 (html-write "- ~a" (get-iso-date-time))))
367
368 (defun make-navbar (&key index next prev name)
369 "Adds the HTML code for the navigation bar."
370 (declare (type (or null pathname) prev next index))
371 (when (or (not name) (not index)) (return-from make-navbar nil))
372 (with-tag (:div (:id "navbar"))
373 (with-tag (:table
374 (:cellspacing 0 :cellpadding 0 :border 0 :style "width: 100%;"))
375 (with-tag (:colgroup (:span 3))
376 (with-tag (:col (:width "0*")))
377 (with-tag (:col (:width "0*")))
378 (with-tag (:col (:width "1*"))))
379 (with-tag (:tr ())
380 (with-tag (:td (:align "left" :valign "baseline"))
381 (when prev
382 (with-tag (:a (:href (namestring prev)))
383 (html-write "Prev:&nbsp;~a" (pathname-name prev))))
384 (with-tag (:br ()))
385 (when next
386 (with-tag (:a (:href (namestring next)))
387 (html-write "Next:&nbsp;~a" (pathname-name next)))))
388 (with-tag (:td ()) (html-write "&nbsp;&nbsp;&nbsp;&nbsp;"))
389 (with-tag (:td (:align "left" :valign "baseline"))
390 (with-tag (:span (:class "upchain"))
391 (with-tag (:b ()) (html-write "~a" name))
392 (with-tag (:br ()))
393 (with-tag (:a (:href (namestring index)))
394 (html-write "~:(~a~)" (pathname-name index))))
395 (html-write "&nbsp;&nbsp;&nbsp;&nbsp;"))))))
396
397 (defun toc-path-from (from dest-dir)
398 (declare (type (or string pathname) from))
399 (let ((toc (merge-pathnames "index.html" dest-dir)))
400 (make-pathname-relative :from from :to toc)))
401
402 ;;;
403 ;;; HTML index creation facilities
404 ;;;
405
406 (defgeneric href-title (symbol-descriptor)
407 (:documentation "Returns a string for the title attribute of an href.")
408 (:method ((symdesc symbol-descriptor))
409 (purge-string-for-html (fully-qualified-name symdesc)))
410 (:method ((symdesc lambda-descriptor))
411 (let ((name (purge-string-for-html (fully-qualified-name symdesc)))
412 (ll (format nil "(~{~s~^ ~})" (lambda-list symdesc))))
413 (concatenate 'string name " " (purge-string-for-html ll)))))
414
415 (defmacro with-index-header
416 ((index hdriver dest-dir title &key (head-title title)) &body body)
417 (with-gensym (href ttitle iindex ddir)
418 `(with-slots (filter css-pathname charset) ,hdriver
419 (let* ((*print-case* :downcase)
420 (,iindex ,index)
421 (,ddir ,dest-dir)
422 (,ttitle ,title)
423 (,href (make-pathname-relative
424 :from (truename ,ddir) :to (truename css-pathname))))
425 (with-open-file (os ,iindex :direction :output :if-exists :supersede)
426 (with-html-page
427 (os :csshref (namestring ,href)
428 :content-type (format nil "text/html; charset=~a" charset)
429 :head-title ,head-title
430 :nav-name ,ttitle
431 :index (toc-path-from (pathname os) ,ddir))
432 (with-tag (:div (:class "cludg-index-body"))
433 (when ,ttitle (with-tag (:h2 ()) (html-write "~a~%" ,ttitle)))
434 (with-tag (:div ()) ,@body))))
435 (enough-namestring (truename ,iindex) (truename ,ddir))))))
436
437 (defun make-abc-index-entry (filename &key char-code non-alphabetic)
438 (let* ((name (file-namestring filename))
439 (href (format nil "~a#_~a" name (or char-code non-alphabetic))))
440 (with-tag (:a (:href href))
441 (html-write
442 (if char-code (format nil "~c" (code-char char-code)) "non-alphabetic"))
443 (html-write "&nbsp;&nbsp;"))))
444
445 (defun make-index-entry (meta-descriptors &key char-code non-alphabetic filter)
446 (flet ((char-code-string () (format nil "~:@(~c~)..." (code-char char-code)))
447 (first-char-p (name char)
448 (let ((c (char name 0)))
449 (char-equal char (if (char= c #\() (char name 1) c)))))
450 (with-tag (:a (:id (format nil "_~a" (or char-code non-alphabetic)))) "")
451 (with-tag (:div (:class "abc-entry"))
452 (with-tag (:h3 ())
453 (html-write (if char-code (char-code-string) "non-alphabetic")))
454 (loop with entry = (and char-code (code-char char-code))
455 for mdesc in meta-descriptors
456 for desc = (meta-descriptor-desc mdesc)
457 if (or (and entry (first-char-p (name desc) entry)) non-alphabetic)
458 do (unless (and filter (funcall filter desc))
459 (with-tag (:div (:class "index-entry"))
460 (with-tag (:a (:href (meta-descriptor-href mdesc)
461 :title (href-title desc)))
462 (html-write "~a," (purge-string-for-html (name desc))))
463 (with-tag (:em ())
464 (html-write "~a" (html-printable-type desc)))))
465 (pop meta-descriptors)
466 else do (loop-finish)
467 finally (return meta-descriptors)))))
468
469 (defun write-index (filename dest-dir title html-driver meta-descriptors)
470 (let ((na-anchor (format nil "~a" (gensym)))
471 (index-file (namestring (merge-pathnames filename dest-dir))))
472 ;; Remove defpackage-descriptor of the meta-descriptors if any.
473 (let ((desc (meta-descriptor-desc (car meta-descriptors))))
474 (when (typep desc 'defpackage-descriptor)
475 (setf meta-descriptors (cdr meta-descriptors))))
476 (with-index-header (index-file html-driver dest-dir title)
477 ;; generate a b c d ... links
478 (loop for i from (char-code #\a) to (char-code #\z)
479 do (make-abc-index-entry index-file :char-code i))
480 ;; add non-alphabetic
481 (make-abc-index-entry index-file :non-alphabetic na-anchor)
482 ;; the index itself
483 (loop for i from (char-code #\a) to (char-code #\z)
484 do (setf meta-descriptors
485 (make-index-entry
486 meta-descriptors :char-code i :filter filter)))
487 ;; add non-alphabetic
488 (make-index-entry
489 meta-descriptors
490 :non-alphabetic na-anchor
491 :filter filter))))
492
493 (defun make-toc (html-driver dest-dir package-index-files)
494 "Writes the table of contents. Returns the file truename of the
495 table of contents."
496 (let ((toc (namestring (merge-pathnames "index.html" dest-dir))))
497 (with-index-header (toc html-driver dest-dir nil :head-title "TOC")
498 (with-slots (toc-title) html-driver
499 (if toc-title
500 (with-tag (:h1 (:class "center")) (html-write toc-title))
501 (with-tag (:h2 ()) (html-write "Table of Contents"))))
502 (with-tag (:br ()))
503 (with-tag (:ul ())
504 (loop with i = 0
505 for (key pkg-index-href files) in package-index-files
506 for part-num from 1 do
507 (with-tag (:li (:style "list-style-type: none"))
508 (with-tag (:a (:href pkg-index-href))
509 (html-write "Part ~@R:&nbsp;~a~%" part-num key))
510 (with-tag (:ul ())
511 (loop for file in files
512 for name = (pathname-name file) do
513 (with-tag (:li (:style "list-style-type: none"))
514 (with-tag (:a (:href file))
515 (if (string/= name "the-index")
516 (html-write "~d&nbsp;~a~%" (incf i) name)
517 (html-write "&nbsp;Index"))))))))))))
518
519 (defun get-defpackage-descriptor (meta-descriptors package-table)
520 "Finds all the defpackage-descriptor and insert them in the package-table."
521 (loop for val in meta-descriptors
522 for desc = (meta-descriptor-desc val)
523 when (typep desc 'defpackage-descriptor)
524 do (setf (gethash (name desc) package-table) (list val))))
525
526 (defun get-descriptors-by-package (html-driver mdescriptors package-table)
527 "Finds all descriptors of each package and add them to their package entry
528 of the package-table. Descriptors will be filtered according to the
529 filter of the html-driver instance."
530 (loop with filter = (filter html-driver)
531 for meta-desc in mdescriptors
532 for desc = (meta-descriptor-desc meta-desc)
533 for add-p = (not (or (not filter) (funcall filter desc)))
534 for pname = (dpackage desc)
535 ;; Search the meta-desc package-name entry
536 if (and add-p (gethash pname package-table))
537 do (push meta-desc (gethash pname package-table))
538 ;; Else search the meta-desc (string-upcase package-name) entry
539 else if (and add-p (gethash (string-upcase pname) package-table))
540 do (push meta-desc (gethash (string-upcase pname) package-table))
541 ;; Else meta-desc package entry is not in the table. Lets create the
542 ;; entry and add the meta-desc if desc is not a defpackage-descriptor.
543 else if (and add-p (not (typep desc 'defpackage-descriptor)))
544 do (push meta-desc (gethash pname package-table))))
545
546 (defun make-indexes (dest-dir html-driver)
547 "Creates package index files, global index and table of contents."
548 (declare (type string dest-dir))
549 (let ((meta-descriptors '())
550 (the-index "the-index.html")
551 the-href)
552 ;; Sort meta-descriptors by alphabetic order.
553 (setf meta-descriptors (desc-sort (cache-meta-descriptors)
554 #'alphabetical-order
555 :key #'meta-descriptor-desc))
556 ;; Write general html index file.
557 (setf the-href (write-index
558 the-index dest-dir "Index" html-driver meta-descriptors))
559 (let ((package-table (make-hash-table :test #'equal))
560 (package-index-files '()))
561 ;; Find all defpackage descriptor.
562 (get-defpackage-descriptor meta-descriptors package-table)
563 ;; Find all html descriptors of each packages.
564 (get-descriptors-by-package html-driver meta-descriptors package-table)
565 ;; Write a descriptors index file for each package.
566 (loop for key being each hash-key in package-table using (hash-value mds)
567 for file = (format nil "~a-index.html" key)
568 for href = (write-index file dest-dir key html-driver (reverse mds))
569 for files = (mapcar #'meta-descriptor-file
570 (stable-sort mds #'< :key #'meta-descriptor-index))
571 do (push
572 (list key href (delete-duplicates files :test #'string-equal))
573 package-index-files))
574 ;; Sort package-index-files in reverse file index order.
575 (flet ((key (l)
576 (meta-descriptor-index (car (gethash (car l) package-table)))))
577 (setf package-index-files
578 (stable-sort package-index-files #'> :key #'key)))
579 ;; Push the-index in package-index-files.
580 (push (list "Index" the-href (list the-index)) package-index-files)
581 ;; Write table of contents in "index.html in the initial order".
582 (make-toc html-driver dest-dir (reverse package-index-files)))))
583
584 ;;;
585 ;;; Summary tables facilities.
586 ;;;
587
588 (defun find-descs (desc-type descs)
589 "Returns the list of symbol descriptors that are of type desc-type."
590 (loop for desc in descs when (typep desc desc-type) collect desc))
591
592 (defun make-summary (summary-title descs filter &key key)
593 "Creates a summary table with the given descriptors. The created table will
594 have two columns. The first one will present hyper link with the descriptor
595 name and the second one the summary as returned by the :key function.
596 Descriptor list will be filtered according to the filter function when
597 provided. The :key argument is a designator for a function of one argument
598 of type symbol-descriptor and returns a string."
599 (when filter (setf descs (delete-if filter descs)))
600 (when descs
601 (with-tag (:table (:style "width: 100%;" :class "summary-table"))
602 (with-tag (:tr (:class "table-heading-color"))
603 (with-tag (:th (:class "summary" :colspan "2"))
604 (html-write summary-title )))
605 (loop for desc in (desc-sort descs #'alphabetical-order)
606 for mdesc = (lookup-meta-descriptor desc)
607 when mdesc
608 do (with-tag (:tr (:class "table-row-color"))
609 (with-tag (:td (:class "summary-name"))
610 (with-tag (:a (:href (meta-descriptor-href mdesc :local)))
611 (html-write (purge-string-for-html (name desc)))))
612 (with-tag (:td (:class "summary"))
613 (let ((string (funcall key desc)))
614 (when string (html-write "~a" string)))))))))
615
616 (defun make-constant-summary (descs filter)
617 "Creates a summary table for defconstant descriptors if any."
618 (let ((defconstants (find-descs 'defconstant-descriptor descs)))
619 (flet ((key (desc) (purge-lambda-list-for-html (value desc))))
620 (make-summary "Constant summary" defconstants filter :key #'key))))
621
622 (defun make-class-summary (descs filter)
623 "Creates summary tables for defclass, define-condition and defstruct
624 descriptors if any."
625 (flet ((key (desc) (format-inheritence desc)))
626 (mapc #'(lambda (title descs) (make-summary title descs filter :key #'key))
627 '("Class summary" "Condition summary" "Structure summary")
628 (list (find-descs 'defclass-descriptor descs)
629 (find-descs 'define-condition-descriptor descs)
630 (find-descs 'defstruct-descriptor descs)))))
631
632 (defun make-function-summary (descs filter)
633 "Creates summary tables for defun, defsetf, defmethod, defgeneric and
634 defmacro descriptors if any."
635 ;; Because neither the defstruct nor the defclass nor the define-condition
636 ;; accessors are present in the list of descriptors they will be retrieved
637 ;; manually and added to defun or defmethod list before call make-summary.
638 (flet ((mapconc (fun list) (apply #'concatenate 'list (mapcar fun list))))
639 (let* ((defmethods '(or defgeneric-descriptor defmethod-descriptor))
640 (defuns '(or defun-descriptor defsetf-descriptor))
641 (class-types '(or defclass-descriptor define-condition-descriptor))
642 (defstructs (find-descs 'defstruct-descriptor descs))
643 (classes (mapconc #'slot-accessors (find-descs class-types descs)))
644 (structs (mapconc #'slot-accessors defstructs)))
645 ;; Add desfstruct copier, predicate, printer and constructors if any.
646 (nconc structs (mapconc #'constructors defstructs))
647 (loop for struct in defstructs
648 do (with-slots (copier predicate printer) struct
649 (and copier (push copier structs))
650 (and predicate (push predicate structs))
651 (and printer (push printer structs))))
652 ;; Last but not least: make summary !
653 (flet ((key (desc) (purge-lambda-list-for-html (lambda-list desc))))
654 (mapc #'(lambda (title descs)
655 (make-summary title descs filter :key #'key))
656 '("Method summary" "Function summary" "Macro summary")
657 (list (concatenate 'list (find-descs defmethods descs) classes)
658 (concatenate 'list (find-descs defuns descs) structs)
659 (find-descs 'defmacro-descriptor descs)))))))
660 ;;;
661 ;;; Public
662 ;;;
663
664 (defvar *class-inheritence* "inherits from"
665 "Defclass inheritence indication control string for automatic documentation.
666 This control string has no parameter.")
667
668 (defvar *condition-inheritence* "inherits from"
669 "Define-condition inheritence indication control string for automatic
670 documentation. This control string has no parameter.")
671
672 (defvar *struct-inheritence* "includes"
673 "Defstruct include indication control string for automatic documentation.
674 This control string has no parameter.")
675
676 (defun resolve-link (symdesc strings)
677 (let ((schemes '("http://" "ftp://"))
678 (file (meta-descriptor-file (lookup-meta-descriptor symdesc))))
679 (if (some #'(lambda (scheme) (starts-with (first strings) scheme)) schemes)
680 (values T (format nil "~{~a~^ ~}" strings))
681 (multiple-value-bind (name package) (split-name (second strings))
682 (let ((href (lookup-meta-descriptor-href
683 (or name "") (first strings) package file)))
684 (values (if href T NIL) href name))))))
685
686 (defun format-doc (symdesc html-driver strings)
687 "Default documentation string formater. The Do What I Mean capabilities
688 are delegated to the create-doctree-from-string method of the doctree
689 protocol in coordination with with-tree-loop iterator to produced the
690 final output."
691 (with-slots ((spi string-parser-initargs)) html-driver
692 (let* ((link-delims (getf spi :link-delimiters +default-link-delimiters+))
693 (left-link-delim (first link-delims))
694 (right-link-delim (second link-delims)))
695 (labels ((map-over-tree (tree)
696 (with-tree-loop (element tree)
697 (if (stringp element)
698 (html-write "~a " element)
699 (case (tree-tag element)
700 (:keyword
701 (with-tag (:span (:class "keyword"))
702 (map-over-tree element)))
703 (:hyper-link
704 (let ((link '()))
705 (with-tree-loop (e element) (push e link))
706 (multiple-value-bind (found-p href name)
707 (resolve-link symdesc (reverse link))
708 (if (and found-p href)
709 (with-tag (:a (:href href))
710 (html-write (or name href)))
711 ;; No link can be created from the given
712 ;; information. Maybe the author was not
713 ;; thinking to an hyper link, for this
714 ;; reason the text will be outputed as
715 ;; it was initially found.
716 (html-write "~a~{~a~^ ~}~a"
717 left-link-delim
718 (reverse link)
719 right-link-delim)))))
720 (t (with-tag ((tree-tag element) ())
721 (map-over-tree element))))))))
722 (map-over-tree
723 (apply #'create-doctree-from-string 'doctree strings spi))))))
724
725 (defun make-html-doc (hdriver filenames &key (dest-dir ".") path-prefix)
726 "Reads all files specified in filenames and extract their documentation
727 using HTML as output. The extracted documentation will be written in a
728 newly created file with the same name as the processed one. If dest-dir
729 is specified then it will be used to construct the output pathname,
730 otherwise the output pathname will be constructed using the one of the
731 currently processed input file pruned from path-prefix."
732 (declare (type list filenames))
733 (declare (type string dest-dir))
734 (unless (char= (char dest-dir (1- (length dest-dir))) #\/)
735 (setf dest-dir (concatenate 'string dest-dir "/")))
736 (ensure-directories-exist dest-dir)
737 (setf filenames (add-prefix-if-necessary path-prefix filenames))
738 (multiple-value-bind (files-and-descriptors *unhandled-forms*)
739 (apply #'initialise-cache dest-dir :html path-prefix filenames)
740 (with-slots (filter css-pathname charset sort-predicate) hdriver
741 (setf css-pathname (copy-css hdriver :dest-dir dest-dir))
742 (make-indexes dest-dir hdriver)
743 (loop with css-truename = (truename css-pathname)
744 with *current-package* = "common-lisp-user"
745 with *print-case* = :downcase
746 with html-content = (format nil "text/html; charset=~a" charset)
747 for (ifile descriptors) in files-and-descriptors and index from 0
748 for title = (pathname-name (truename ifile))
749 for of = (make-output-pathname ifile dest-dir :html path-prefix)
750 for css = (make-pathname-relative :from of :to css-truename)
751 for next = (next files-and-descriptors index dest-dir path-prefix)
752 for prev = (prev files-and-descriptors index dest-dir path-prefix)
753 do (with-open-file (os of :direction :output :if-exists :supersede)
754 (with-html-page
755 (os :csshref (namestring css) :content-type html-content
756 :head-title title :nav-name (pathname-name os)
757 :index (toc-path-from of (truename dest-dir))
758 :prev prev :next next)
759 ;; Append all documentation.
760 (with-tag (:div (:class "cludg-doc-body"))
761 (with-tag (:h2 ()) (html-write "~a~%" title))
762 (let ((descs (desc-sort descriptors sort-predicate)))
763 (make-constant-summary descs filter)
764 (make-class-summary descs filter)
765 (make-function-summary descs filter)
766 (loop for desc in descs
767 do (with-slots (name type) desc
768 (unless (and filter (funcall filter desc))
769 (dformat desc hdriver os))))))))))
770 (remove-duplicates *unhandled-forms*)))
771
772 ;;;
773 ;;; Purger.
774 ;;;
775
776 (define-purgers
777 :string-purger
778 (purge-string-for-html
779 ((#\& "&amp;")
780 (#\" "&quot;")
781 (#\< "&lt;")
782 (#\> "&gt;"))
783 (:documentation "Tries to purge a string from characters that
784 are potentially dangerous for HTML."))
785 :lambda-list-purger
786 (purge-lambda-list-for-html
787 (("&key" "<em>&amp;key</em>")
788 ("&optional" "<em>&amp;optional</em>")
789 ("&rest" "<em>&amp;rest</em>")
790 ("&allow-other-keys" "<em>&amp;allow-other-keys</em>")
791 ("&body" "<em>&amp;body</em>")
792 ("&aux" "<em>&amp;aux</em>")
793 ("&environment" "<em>&amp;environment</em>")
794 ("&whole" "<em>&amp;whole</em>"))
795 (:documentation "Tries to purge a lambda-list from characters that are
796 potentially dangerous for HTML.")))
797
798 ;;;
799 ;;; Misc.
800 ;;;
801
802 (defgeneric html-printable-type (symbol-descriptor)
803 (:documentation "Returns an HTML string that will be used to instead of
804 the desc-type. If such a overload is not found the value returned by
805 desc-type will be used.")
806 (:method ((symbol-descriptor symbol-descriptor))
807 (desc-type symbol-descriptor))
808 (:method ((symbol-descriptor defpackage-descriptor)) "Package")
809 (:method ((symbol-descriptor defclass-descriptor)) "Class")
810 (:method ((symbol-descriptor define-condition-descriptor)) "Condition")
811 (:method ((symbol-descriptor defstruct-descriptor)) "Structure")
812 (:method ((symbol-descriptor deftype-descriptor)) "Type")
813 (:method ((symbol-descriptor defconstant-descriptor)) "Constant")
814 (:method ((symbol-descriptor defparameter-descriptor)) "Variable")
815 (:method ((symbol-descriptor defvar-descriptor)) "Variable")
816 (:method ((symbol-descriptor defun-descriptor)) "Function")
817 (:method ((symbol-descriptor defmacro-descriptor)) "Macro")
818 (:method ((symbol-descriptor defsetf-descriptor)) "Setf&nbsp;Function")
819 (:method ((symbol-descriptor defgeneric-descriptor)) "Generic&nbsp;Function")
820 (:method ((symbol-descriptor slot-descriptor)) "Slot")
821 (:method ((symbol-descriptor defmethod-descriptor))
822 (case (car (method-qualifiers symbol-descriptor))
823 (:before "Before&nbsp;Method")
824 (:around "Around&nbsp;Method")
825 (:after "After&nbsp;Method")
826 (t "Method"))))
827
828 (defgeneric find-inheritence-word (symbol-descriptor)
829 (:documentation "Returns an HTML string that will be used to instead of
830 the desc-type. If such a overload is not found the value returned by
831 desc-type will be used.")
832 (:method ((symbol-descriptor symbol-descriptor)) "")
833 (:method ((symbol-descriptor defclass-descriptor)) *class-inheritence*)
834 (:method ((symbol-descriptor defstruct-descriptor)) *struct-inheritence*)
835 (:method ((symbol-descriptor define-condition-descriptor))
836 *condition-inheritence*))
837
838 (defun format-inheritence (structured-object-descriptor)
839 "Resolves the inheritence/inclusion of structured-object-descriptor in order
840 to return an HTML string that describes the inheritence with hyper links."
841 (flet ((em (string) (format nil "<em class=\"cl\">~a</em>" string))
842 (href (href string) (format nil "<a href=\"~a\">~a</a>" href string)))
843 (let ((inheritence (inheritence structured-object-descriptor))
844 (meta-desc (lookup-meta-descriptor structured-object-descriptor))
845 (super-desc-type (type-of structured-object-descriptor))
846 (package-name (dpackage structured-object-descriptor)))
847 (when inheritence
848 (format nil "~a ~{~a~#[~; and ~:;, ~]~}"
849 (find-inheritence-word structured-object-descriptor)
850 (mapcar #'(lambda (super)
851 (multiple-value-bind (pname ssuper)
852 (resolve-symbol-package-name super package-name)
853 (let ((s (em (purge-string-for-html ssuper)))
854 (href (lookup-meta-descriptor-href
855 ssuper super-desc-type pname
856 (meta-descriptor-file meta-desc))))
857 (if href (href href s) s))))
858 inheritence))))))
859
860 ;;;
861 ;;; dformat-documentation protocol.
862 ;;;
863
864 (defmethod dformat-documentation (desc (driver html) stream)
865 (declare (ignorable stream))
866 (htmlify-doc desc :html-driver driver))
867
868 (defmethod dformat-documentation
869 ((desc structured-object-descriptor) (driver html) os)
870 (htmlify-doc desc :html-driver driver)
871 (when (slots desc)
872 (with-tag (:div (:class "defclass-initargs"))
873 (loop for slot in (slots desc)
874 for iargs = (format nil "~{~s~^ ~}" (initargs slot))
875 when (initargs slot)
876 do (with-html-description
877 (:divclass nil :name iargs :type "Initarg"))))
878 (with-tag (:div (:class "defclass-slots-doc"))
879 (loop for slot in (slots desc) do (dformat slot driver os)))
880 (with-tag (:div (:class "defclass-generics"))
881 (loop for desc in (slot-accessors desc)
882 unless (and (filter driver) (funcall (filter driver) desc))
883 do (dformat desc driver os)))))
884
885 ;;;
886 ;;; dformat protocol.
887 ;;;
888
889 (defmethod dformat ((desc in-package-form) (driver html) os)
890 (declare (ignorable driver os desc))
891 (setf *current-package* (dest-package desc)))
892
893 (defmethod dformat ((desc defpackage-descriptor) (driver html) os)
894 (with-html-description
895 (:name (purge-string-for-html (name desc))
896 :type (html-printable-type desc)
897 :anchor (lookup-meta-descriptor-anchor desc)
898 :divclass "defpackage")
899 (dformat-documentation desc driver os)))
900
901 (defmethod dformat ((desc param-descriptor) (driver html) os)
902 (with-html-description
903 (:name (purge-string-for-html (name desc))
904 :type (html-printable-type desc)
905 :anchor (lookup-meta-descriptor-anchor desc)
906 :divclass "defparam")
907 (dformat-documentation desc driver os)))
908
909 (defmethod dformat ((desc deftype-descriptor) (driver html) os)
910 (with-html-description
911 (:name (purge-string-for-html (name desc))
912 :type (html-printable-type desc)
913 :arg-list (purge-lambda-list-for-html (value desc))
914 :anchor (lookup-meta-descriptor-anchor desc)
915 :divclass "deftype")
916 (dformat-documentation desc driver os)))
917
918 (defmethod dformat ((desc defconstant-descriptor) (driver html) os)
919 (with-html-description
920 (:name (purge-string-for-html (name desc))
921 :type (html-printable-type desc)
922 :arg-list (purge-lambda-list-for-html (value desc))
923 :anchor (lookup-meta-descriptor-anchor desc)
924 :divclass "defconstant")
925 (dformat-documentation desc driver os)))
926
927 (defmethod dformat ((desc lambda-descriptor) (driver html) os)
928 (with-html-description
929 (:name (purge-string-for-html (name desc))
930 :arg-list (purge-lambda-list-for-html (lambda-list desc))
931 :type (html-printable-type desc)
932 :anchor (lookup-meta-descriptor-anchor desc))
933 (dformat-documentation desc driver os)))
934
935 (defmethod dformat ((desc defsetf-short-descriptor) (driver html) os)
936 (with-html-description
937 (:name (purge-string-for-html (name desc))
938 :arg-list (purge-lambda-list-for-html (list (update-fn desc)))
939 :type (html-printable-type desc)
940 :anchor (lookup-meta-descriptor-anchor desc))
941 (dformat-documentation desc driver os)))
942
943 (defmethod dformat ((desc defsetf-long-descriptor) (driver html) os)
944 (let ((name (purge-string-for-html (name desc))))
945 (with-slots (extra-args) desc
946 (when extra-args
947 (setf name (format nil "(setf ~a <em class=\"args\">~a</em>)"
948 (subseq name 6 (1- (length name)))
949 (purge-lambda-list-for-html extra-args)))))
950 (with-html-description
951 (:name name
952 :arg-list (purge-lambda-list-for-html (list (lambda-list desc)))
953 :type (html-printable-type desc)
954 :anchor (lookup-meta-descriptor-anchor desc))
955 (dformat-documentation desc driver os))))
956
957 (defmethod dformat ((desc structured-object-descriptor) (driver html) os)
958 (with-html-description
959 (:name (purge-string-for-html (name desc))
960 :arg-list (format-inheritence desc)
961 :type (html-printable-type desc)
962 :anchor (lookup-meta-descriptor-anchor desc)
963 :divclass "defclass")
964 (dformat-documentation desc driver os)))
965
966 (defmethod dformat ((desc defstruct-descriptor) (driver html) os)
967 (flet ((format-defun (desc)
968 (unless (and (filter driver) (funcall (filter driver) desc))
969 (dformat desc driver os))))
970 (with-html-description
971 (:name (purge-string-for-html (name desc))
972 :type (html-printable-type desc)
973 :anchor (lookup-meta-descriptor-anchor desc)
974 :divclass "defstruct")
975 (dformat-documentation desc driver os)
976 (with-tag (:div (:class "defstruct-defuns"))
977 (mapc #'format-defun (constructors desc))
978 (when (copier desc) (format-defun (copier desc)))
979 (when (predicate desc) (format-defun (predicate desc)))))))
980
981 (defmethod dformat ((desc slot-descriptor) (driver html) os)
982 (declare (ignorable os))
983 (when (doc desc)
984 (with-html-description
985 (:divclass nil :name (name desc) :type (html-printable-type desc))
986 (dformat-documentation desc driver os))))
987
988 (defmethod dformat ((desc defstruct-slot-descriptor) (driver html) os)
989 (declare (ignorable desc driver os)))

  ViewVC Help
Powered by ViewVC 1.1.5