tdocstrings.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) LICENSE
---
tdocstrings.lisp (34765B)
---
1 ;;; -*- lisp -*-
2
3 ;;;; A docstring extractor for the sbcl manual. Creates
4 ;;;; @include-ready documentation from the docstrings of exported
5 ;;;; symbols of specified packages.
6
7 ;;;; This software is part of the SBCL software system. SBCL is in the
8 ;;;; public domain and is provided with absolutely no warranty. See
9 ;;;; the COPYING file for more information.
10 ;;;;
11 ;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled
12 ;;;; by Nikodemus Siivola.
13
14 ;;;; TODO
15 ;;;; * Verbatim text
16 ;;;; * Quotations
17 ;;;; * Method documentation untested
18 ;;;; * Method sorting, somehow
19 ;;;; * Index for macros & constants?
20 ;;;; * This is getting complicated enough that tests would be good
21 ;;;; * Nesting (currently only nested itemizations work)
22 ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also
23 ;;;; easily generated)
24
25 ;;;; FIXME: The description below is no longer complete. This
26 ;;;; should possibly be turned into a contrib with proper documentation.
27
28 ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
29 ;;;;
30 ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
31 ;;;; the argument list of the defun / defmacro.
32 ;;;;
33 ;;;; Lines starting with * or - that are followed by intented lines
34 ;;;; are marked up with @itemize.
35 ;;;;
36 ;;;; Lines containing only a SYMBOL that are followed by indented
37 ;;;; lines are marked up as @table @code, with the SYMBOL as the item.
38
39 (eval-when (:compile-toplevel :load-toplevel :execute)
40 (require 'sb-introspect))
41
42 (defpackage :sb-texinfo
43 (:use :cl :sb-mop)
44 (:shadow #:documentation)
45 (:export #:generate-includes #:document-package)
46 (:documentation
47 "Tools to generate TexInfo documentation from docstrings."))
48
49 (in-package :sb-texinfo)
50
51 ;;;; various specials and parameters
52
53 (defvar *texinfo-output*)
54 (defvar *texinfo-variables*)
55 (defvar *documentation-package*)
56 (defvar *base-package*)
57
58 (defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c))
59
60 (defparameter *documentation-types*
61 '(compiler-macro
62 function
63 method-combination
64 setf
65 ;;structure ; also handled by `type'
66 type
67 variable)
68 "A list of symbols accepted as second argument of `documentation'")
69
70 (defparameter *character-replacements*
71 '((#\* . "star") (#\/ . "slash") (#\+ . "plus")
72 (#\< . "lt") (#\> . "gt")
73 (#\= . "equals"))
74 "Characters and their replacement names that `alphanumize' uses. If
75 the replacements contain any of the chars they're supposed to replace,
76 you deserve to lose.")
77
78 (defparameter *characters-to-drop* '(#\\ #\` #\')
79 "Characters that should be removed by `alphanumize'.")
80
81 (defparameter *texinfo-escaped-chars* "@{}"
82 "Characters that must be escaped with #\@ for Texinfo.")
83
84 (defparameter *itemize-start-characters* '(#\* #\-)
85 "Characters that might start an itemization in docstrings when
86 at the start of a line.")
87
88 (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'"
89 "List of characters that make up symbols in a docstring.")
90
91 (defparameter *symbol-delimiters* " ,.!?;")
92
93 (defparameter *ordered-documentation-kinds*
94 '(package type structure condition class macro))
95
96 ;;;; utilities
97
98 (defun flatten (list)
99 (cond ((null list)
100 nil)
101 ((consp (car list))
102 (nconc (flatten (car list)) (flatten (cdr list))))
103 ((null (cdr list))
104 (cons (car list) nil))
105 (t
106 (cons (car list) (flatten (cdr list))))))
107
108 (defun whitespacep (char)
109 (find char #(#\tab #\space #\page)))
110
111 (defun setf-name-p (name)
112 (or (symbolp name)
113 (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
114
115 (defgeneric specializer-name (specializer))
116
117 (defmethod specializer-name ((specializer eql-specializer))
118 (list 'eql (eql-specializer-object specializer)))
119
120 (defmethod specializer-name ((specializer class))
121 (class-name specializer))
122
123 (defun ensure-class-precedence-list (class)
124 (unless (class-finalized-p class)
125 (finalize-inheritance class))
126 (class-precedence-list class))
127
128 (defun specialized-lambda-list (method)
129 ;; courtecy of AMOP p. 61
130 (let* ((specializers (method-specializers method))
131 (lambda-list (method-lambda-list method))
132 (n-required (length specializers)))
133 (append (mapcar (lambda (arg specializer)
134 (if (eq specializer (find-class 't))
135 arg
136 `(,arg ,(specializer-name specializer))))
137 (subseq lambda-list 0 n-required)
138 specializers)
139 (subseq lambda-list n-required))))
140
141 (defun string-lines (string)
142 "Lines in STRING as a vector."
143 (coerce (with-input-from-string (s string)
144 (loop for line = (read-line s nil nil)
145 while line collect line))
146 'vector))
147
148 (defun indentation (line)
149 "Position of first non-SPACE character in LINE."
150 (position-if-not (lambda (c) (char= c #\Space)) line))
151
152 (defun docstring (x doc-type)
153 (cl:documentation x doc-type))
154
155 (defun flatten-to-string (list)
156 (format nil "~{~A~^-~}" (flatten list)))
157
158 (defun alphanumize (original)
159 "Construct a string without characters like *`' that will f-star-ck
160 up filename handling. See `*character-replacements*' and
161 `*characters-to-drop*' for customization."
162 (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
163 (if (listp original)
164 (flatten-to-string original)
165 (string original))))
166 (chars-to-replace (mapcar #'car *character-replacements*)))
167 (flet ((replacement-delimiter (index)
168 (cond ((or (< index 0) (>= index (length name))) "")
169 ((alphanumericp (char name index)) "-")
170 (t ""))))
171 (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
172 name)
173 while index
174 do (setf name (concatenate 'string (subseq name 0 index)
175 (replacement-delimiter (1- index))
176 (cdr (assoc (aref name index)
177 *character-replacements*))
178 (replacement-delimiter (1+ index))
179 (subseq name (1+ index))))))
180 name))
181
182 ;;;; generating various names
183
184 (defgeneric name (thing)
185 (:documentation "Name for a documented thing. Names are either
186 symbols or lists of symbols."))
187
188 (defmethod name ((symbol symbol))
189 symbol)
190
191 (defmethod name ((cons cons))
192 cons)
193
194 (defmethod name ((package package))
195 (short-package-name package))
196
197 (defmethod name ((method method))
198 (list
199 (generic-function-name (method-generic-function method))
200 (method-qualifiers method)
201 (specialized-lambda-list method)))
202
203 ;;; Node names for DOCUMENTATION instances
204
205 (defgeneric name-using-kind/name (kind name doc))
206
207 (defmethod name-using-kind/name (kind (name string) doc)
208 (declare (ignore kind doc))
209 name)
210
211 (defmethod name-using-kind/name (kind (name symbol) doc)
212 (declare (ignore kind))
213 (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
214
215 (defmethod name-using-kind/name (kind (name list) doc)
216 (declare (ignore kind))
217 (assert (setf-name-p name))
218 (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
219
220 (defmethod name-using-kind/name ((kind (eql 'method)) name doc)
221 (format nil "~A~{ ~A~} ~A"
222 (name-using-kind/name nil (first name) doc)
223 (second name)
224 (third name)))
225
226 (defun node-name (doc)
227 "Returns TexInfo node name as a string for a DOCUMENTATION instance."
228 (let ((kind (get-kind doc)))
229 (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
230
231 (defun short-package-name (package)
232 (unless (eq package *base-package*)
233 (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
234 #'< :key #'length))))
235
236 ;;; Definition titles for DOCUMENTATION instances
237
238 (defgeneric title-using-kind/name (kind name doc))
239
240 (defmethod title-using-kind/name (kind (name string) doc)
241 (declare (ignore kind doc))
242 name)
243
244 (defmethod title-using-kind/name (kind (name symbol) doc)
245 (declare (ignore kind))
246 (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name))
247
248 (defmethod title-using-kind/name (kind (name list) doc)
249 (declare (ignore kind))
250 (assert (setf-name-p name))
251 (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name)))
252
253 (defmethod title-using-kind/name ((kind (eql 'method)) name doc)
254 (format nil "~{~A ~}~A"
255 (second name)
256 (title-using-kind/name nil (first name) doc)))
257
258 (defun title-name (doc)
259 "Returns a string to be used as name of the definition."
260 (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
261
262 (defun include-pathname (doc)
263 (let* ((kind (get-kind doc))
264 (name (nstring-downcase
265 (if (eq 'package kind)
266 (format nil "package-~A" (alphanumize (get-name doc)))
267 (format nil "~A-~A-~A"
268 (case (get-kind doc)
269 ((function generic-function) "fun")
270 (structure "struct")
271 (variable "var")
272 (otherwise (symbol-name (get-kind doc))))
273 (alphanumize (let ((*base-package* nil))
274 (short-package-name (get-package doc))))
275 (alphanumize (get-name doc)))))))
276 (make-pathname :name name :type "texinfo")))
277
278 ;;;; documentation class and related methods
279
280 (defclass documentation ()
281 ((name :initarg :name :reader get-name)
282 (kind :initarg :kind :reader get-kind)
283 (string :initarg :string :reader get-string)
284 (children :initarg :children :initform nil :reader get-children)
285 (package :initform *documentation-package* :reader get-package)))
286
287 (defmethod print-object ((documentation documentation) stream)
288 (print-unreadable-object (documentation stream :type t)
289 (princ (list (get-kind documentation) (get-name documentation)) stream)))
290
291 (defgeneric make-documentation (x doc-type string))
292
293 (defmethod make-documentation ((x package) doc-type string)
294 (declare (ignore doc-type))
295 (make-instance 'documentation
296 :name (name x)
297 :kind 'package
298 :string string))
299
300 (defmethod make-documentation (x (doc-type (eql 'function)) string)
301 (declare (ignore doc-type))
302 (let* ((fdef (and (fboundp x) (fdefinition x)))
303 (name x)
304 (kind (cond ((and (symbolp x) (special-operator-p x))
305 'special-operator)
306 ((and (symbolp x) (macro-function x))
307 'macro)
308 ((typep fdef 'generic-function)
309 (assert (or (symbolp name) (setf-name-p name)))
310 'generic-function)
311 (fdef
312 (assert (or (symbolp name) (setf-name-p name)))
313 'function)))
314 (children (when (eq kind 'generic-function)
315 (collect-gf-documentation fdef))))
316 (make-instance 'documentation
317 :name (name x)
318 :string string
319 :kind kind
320 :children children)))
321
322 (defmethod make-documentation ((x method) doc-type string)
323 (declare (ignore doc-type))
324 (make-instance 'documentation
325 :name (name x)
326 :kind 'method
327 :string string))
328
329 (defmethod make-documentation (x (doc-type (eql 'type)) string)
330 (make-instance 'documentation
331 :name (name x)
332 :string string
333 :kind (etypecase (find-class x nil)
334 (structure-class 'structure)
335 (standard-class 'class)
336 (sb-pcl::condition-class 'condition)
337 ((or built-in-class null) 'type))))
338
339 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
340 (make-instance 'documentation
341 :name (name x)
342 :string string
343 :kind (if (constantp x)
344 'constant
345 'variable)))
346
347 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
348 (declare (ignore doc-type))
349 (make-instance 'documentation
350 :name (name x)
351 :kind 'setf-expander
352 :string string))
353
354 (defmethod make-documentation (x doc-type string)
355 (make-instance 'documentation
356 :name (name x)
357 :kind doc-type
358 :string string))
359
360 (defun maybe-documentation (x doc-type)
361 "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
362 there is no corresponding docstring."
363 (let ((docstring (docstring x doc-type)))
364 (when docstring
365 (make-documentation x doc-type docstring))))
366
367 (defun lambda-list (doc)
368 (case (get-kind doc)
369 ((package constant variable type structure class condition nil)
370 nil)
371 (method
372 (third (get-name doc)))
373 (t
374 ;; KLUDGE: Eugh.
375 ;;
376 ;; believe it or not, the above comment was written before CSR
377 ;; came along and obfuscated this. (2005-07-04)
378 (when (symbolp (get-name doc))
379 (labels ((clean (x &key optional key)
380 (typecase x
381 (atom x)
382 ((cons (member &optional))
383 (cons (car x) (clean (cdr x) :optional t)))
384 ((cons (member &key))
385 (cons (car x) (clean (cdr x) :key t)))
386 ((cons (member &whole &environment))
387 ;; Skip these
388 (clean (cdr x) :optional optional :key key))
389 ((cons cons)
390 (cons
391 (cond (key (if (consp (caar x))
392 (caaar x)
393 (caar x)))
394 (optional (caar x))
395 (t (clean (car x))))
396 (clean (cdr x) :key key :optional optional)))
397 (cons
398 (cons
399 (cond ((or key optional) (car x))
400 (t (clean (car x))))
401 (clean (cdr x) :key key :optional optional))))))
402 (clean (sb-introspect:function-lambda-list (get-name doc))))))))
403
404 (defun get-string-name (x)
405 (let ((name (get-name x)))
406 (cond ((symbolp name)
407 (symbol-name name))
408 ((and (consp name) (eq 'setf (car name)))
409 (symbol-name (second name)))
410 ((stringp name)
411 name)
412 (t
413 (error "Don't know which symbol to use for name ~S" name)))))
414
415 (defun documentation< (x y)
416 (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
417 (p2 (position (get-kind y) *ordered-documentation-kinds*)))
418 (if (or (not (and p1 p2)) (= p1 p2))
419 (string< (get-string-name x) (get-string-name y))
420 (< p1 p2))))
421
422 ;;;; turning text into texinfo
423
424 (defun escape-for-texinfo (string &optional downcasep)
425 "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
426 with #\@. Optionally downcase the result."
427 (let ((result (with-output-to-string (s)
428 (loop for char across string
429 when (find char *texinfo-escaped-chars*)
430 do (write-char #\@ s)
431 do (write-char char s)))))
432 (if downcasep (nstring-downcase result) result)))
433
434 (defun empty-p (line-number lines)
435 (and (< -1 line-number (length lines))
436 (not (indentation (svref lines line-number)))))
437
438 ;;; line markups
439
440 (defvar *not-symbols* '("ANSI" "CLHS"))
441
442 (defun locate-symbols (line)
443 "Return a list of index pairs of symbol-like parts of LINE."
444 ;; This would be a good application for a regex ...
445 (let (result)
446 (flet ((grab (start end)
447 (unless (member (subseq line start end) '("ANSI" "CLHS"))
448 (push (list start end) result))))
449 (do ((begin nil)
450 (maybe-begin t)
451 (i 0 (1+ i)))
452 ((= i (length line))
453 ;; symbol at end of line
454 (when (and begin (or (> i (1+ begin))
455 (not (member (char line begin) '(#\A #\I)))))
456 (grab begin i))
457 (nreverse result))
458 (cond
459 ((and begin (find (char line i) *symbol-delimiters*))
460 ;; symbol end; remember it if it's not "A" or "I"
461 (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
462 (grab begin i))
463 (setf begin nil
464 maybe-begin t))
465 ((and begin (not (find (char line i) *symbol-characters*)))
466 ;; Not a symbol: abort
467 (setf begin nil))
468 ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
469 ;; potential symbol begin at this position
470 (setf begin i
471 maybe-begin nil))
472 ((find (char line i) *symbol-delimiters*)
473 ;; potential symbol begin after this position
474 (setf maybe-begin t))
475 (t
476 ;; Not reading a symbol, not at potential start of symbol
477 (setf maybe-begin nil)))))))
478
479 (defun texinfo-line (line)
480 "Format symbols in LINE texinfo-style: either as code or as
481 variables if the symbol in question is contained in symbols
482 *TEXINFO-VARIABLES*."
483 (with-output-to-string (result)
484 (let ((last 0))
485 (dolist (symbol/index (locate-symbols line))
486 (write-string (subseq line last (first symbol/index)) result)
487 (let ((symbol-name (apply #'subseq line symbol/index)))
488 (format result (if (member symbol-name *texinfo-variables*
489 :test #'string=)
490 "@var{~A}"
491 "@code{~A}")
492 (string-downcase symbol-name)))
493 (setf last (second symbol/index)))
494 (write-string (subseq line last) result))))
495
496 ;;; lisp sections
497
498 (defun lisp-section-p (line line-number lines)
499 "Returns T if the given LINE looks like start of lisp code --
500 ie. if it starts with whitespace followed by a paren or
501 semicolon, and the previous line is empty"
502 (let ((offset (indentation line)))
503 (and offset
504 (plusp offset)
505 (find (find-if-not #'whitespacep line) "(;")
506 (empty-p (1- line-number) lines))))
507
508 (defun collect-lisp-section (lines line-number)
509 (let ((lisp (loop for index = line-number then (1+ index)
510 for line = (and (< index (length lines)) (svref lines index))
511 while (indentation line)
512 collect line)))
513 (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
514
515 ;;; itemized sections
516
517 (defun maybe-itemize-offset (line)
518 "Return NIL or the indentation offset if LINE looks like it starts
519 an item in an itemization."
520 (let* ((offset (indentation line))
521 (char (when offset (char line offset))))
522 (and offset
523 (member char *itemize-start-characters* :test #'char=)
524 (char= #\Space (find-if-not (lambda (c) (char= c char))
525 line :start offset))
526 offset)))
527
528 (defun collect-maybe-itemized-section (lines starting-line)
529 ;; Return index of next line to be processed outside
530 (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
531 (result nil)
532 (lines-consumed 0))
533 (loop for line-number from starting-line below (length lines)
534 for line = (svref lines line-number)
535 for indentation = (indentation line)
536 for offset = (maybe-itemize-offset line)
537 do (cond
538 ((not indentation)
539 ;; empty line -- inserts paragraph.
540 (push "" result)
541 (incf lines-consumed))
542 ((and offset (> indentation this-offset))
543 ;; nested itemization -- handle recursively
544 ;; FIXME: tables in itemizations go wrong
545 (multiple-value-bind (sub-lines-consumed sub-itemization)
546 (collect-maybe-itemized-section lines line-number)
547 (when sub-lines-consumed
548 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
549 (incf lines-consumed sub-lines-consumed)
550 (setf result (nconc (nreverse sub-itemization) result)))))
551 ((and offset (= indentation this-offset))
552 ;; start of new item
553 (push (format nil "@item ~A"
554 (texinfo-line (subseq line (1+ offset))))
555 result)
556 (incf lines-consumed))
557 ((and (not offset) (> indentation this-offset))
558 ;; continued item from previous line
559 (push (texinfo-line line) result)
560 (incf lines-consumed))
561 (t
562 ;; end of itemization
563 (loop-finish))))
564 ;; a single-line itemization isn't.
565 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
566 (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
567 nil)))
568
569 ;;; table sections
570
571 (defun tabulation-body-p (offset line-number lines)
572 (when (< line-number (length lines))
573 (let ((offset2 (indentation (svref lines line-number))))
574 (and offset2 (< offset offset2)))))
575
576 (defun tabulation-p (offset line-number lines direction)
577 (let ((step (ecase direction
578 (:backwards (1- line-number))
579 (:forwards (1+ line-number)))))
580 (when (and (plusp line-number) (< line-number (length lines)))
581 (and (eql offset (indentation (svref lines line-number)))
582 (or (when (eq direction :backwards)
583 (empty-p step lines))
584 (tabulation-p offset step lines direction)
585 (tabulation-body-p offset step lines))))))
586
587 (defun maybe-table-offset (line-number lines)
588 "Return NIL or the indentation offset if LINE looks like it starts
589 an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
590 empty line, another tabulation label, or a tabulation body, (3) and
591 followed another tabulation label or a tabulation body."
592 (let* ((line (svref lines line-number))
593 (offset (indentation line))
594 (prev (1- line-number))
595 (next (1+ line-number)))
596 (when (and offset (plusp offset))
597 (and (or (empty-p prev lines)
598 (tabulation-body-p offset prev lines)
599 (tabulation-p offset prev lines :backwards))
600 (or (tabulation-body-p offset next lines)
601 (tabulation-p offset next lines :forwards))
602 offset))))
603
604 ;;; FIXME: This and itemization are very similar: could they share
605 ;;; some code, mayhap?
606
607 (defun collect-maybe-table-section (lines starting-line)
608 ;; Return index of next line to be processed outside
609 (let ((this-offset (maybe-table-offset starting-line lines))
610 (result nil)
611 (lines-consumed 0))
612 (loop for line-number from starting-line below (length lines)
613 for line = (svref lines line-number)
614 for indentation = (indentation line)
615 for offset = (maybe-table-offset line-number lines)
616 do (cond
617 ((not indentation)
618 ;; empty line -- inserts paragraph.
619 (push "" result)
620 (incf lines-consumed))
621 ((and offset (= indentation this-offset))
622 ;; start of new item, or continuation of previous item
623 (if (and result (search "@item" (car result) :test #'char=))
624 (push (format nil "@itemx ~A" (texinfo-line line))
625 result)
626 (progn
627 (push "" result)
628 (push (format nil "@item ~A" (texinfo-line line))
629 result)))
630 (incf lines-consumed))
631 ((> indentation this-offset)
632 ;; continued item from previous line
633 (push (texinfo-line line) result)
634 (incf lines-consumed))
635 (t
636 ;; end of itemization
637 (loop-finish))))
638 ;; a single-line table isn't.
639 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
640 (values lines-consumed
641 `("" "@table @emph" ,@(reverse result) "@end table" ""))
642 nil)))
643
644 ;;; section markup
645
646 (defmacro with-maybe-section (index &rest forms)
647 `(multiple-value-bind (count collected) (progn ,@forms)
648 (when count
649 (dolist (line collected)
650 (write-line line *texinfo-output*))
651 (incf ,index (1- count)))))
652
653 (defun write-texinfo-string (string &optional lambda-list)
654 "Try to guess as much formatting for a raw docstring as possible."
655 (let ((*texinfo-variables* (flatten lambda-list))
656 (lines (string-lines (escape-for-texinfo string nil))))
657 (loop for line-number from 0 below (length lines)
658 for line = (svref lines line-number)
659 do (cond
660 ((with-maybe-section line-number
661 (and (lisp-section-p line line-number lines)
662 (collect-lisp-section lines line-number))))
663 ((with-maybe-section line-number
664 (and (maybe-itemize-offset line)
665 (collect-maybe-itemized-section lines line-number))))
666 ((with-maybe-section line-number
667 (and (maybe-table-offset line-number lines)
668 (collect-maybe-table-section lines line-number))))
669 (t
670 (write-line (texinfo-line line) *texinfo-output*))))))
671
672 ;;;; texinfo formatting tools
673
674 (defun hide-superclass-p (class-name super-name)
675 (let ((super-package (symbol-package super-name)))
676 (or
677 ;; KLUDGE: We assume that we don't want to advertise internal
678 ;; classes in CP-lists, unless the symbol we're documenting is
679 ;; internal as well.
680 (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
681 (not (eq super-package (symbol-package class-name))))
682 ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
683 ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
684 ;; simply as a matter of convenience. The assumption here is that
685 ;; the inheritance is incidental unless the name of the condition
686 ;; begins with SIMPLE-.
687 (and (member super-name '(simple-error simple-condition))
688 (let ((prefix "SIMPLE-"))
689 (mismatch prefix (string class-name) :end2 (length prefix)))
690 t ; don't return number from MISMATCH
691 ))))
692
693 (defun hide-slot-p (symbol slot)
694 ;; FIXME: There is no pricipal reason to avoid the slot docs fo
695 ;; structures and conditions, but their DOCUMENTATION T doesn't
696 ;; currently work with them the way we'd like.
697 (not (and (typep (find-class symbol nil) 'standard-class)
698 (docstring slot t))))
699
700 (defun texinfo-anchor (doc)
701 (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
702
703 ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
704 (defun texinfo-begin (doc &aux *print-pretty*)
705 (let ((kind (get-kind doc)))
706 (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
707 (case kind
708 ((package constant variable)
709 "defvr")
710 ((structure class condition type)
711 "deftp")
712 (t
713 "deffn"))
714 (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
715 (title-name doc)
716 ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
717 ;; interactions,so we escape the ampersand -- amusingly for TeX.
718 ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
719 (mapcar (lambda (name)
720 (if (member name lambda-list-keywords)
721 (format nil "@~A" name)
722 name))
723 (lambda-list doc)))))
724
725 (defun texinfo-index (doc)
726 (let ((title (title-name doc)))
727 (case (get-kind doc)
728 ((structure type class condition)
729 (format *texinfo-output* "@tindex ~A~%" title))
730 ((variable constant)
731 (format *texinfo-output* "@vindex ~A~%" title))
732 ((compiler-macro function method-combination macro generic-function)
733 (format *texinfo-output* "@findex ~A~%" title)))))
734
735 (defun texinfo-inferred-body (doc)
736 (when (member (get-kind doc) '(class structure condition))
737 (let ((name (get-name doc)))
738 ;; class precedence list
739 (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
740 (remove-if (lambda (class) (hide-superclass-p name class))
741 (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
742 ;; slots
743 (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
744 (class-direct-slots (find-class name)))))
745 (when slots
746 (format *texinfo-output* "Slots:~%@itemize~%")
747 (dolist (slot slots)
748 (format *texinfo-output*
749 "@item ~(@code{~A}~#[~:; --- ~]~
750 ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
751 (slot-definition-name slot)
752 (remove
753 nil
754 (mapcar
755 (lambda (name things)
756 (if things
757 (list name (length things) things)))
758 '("initarg" "reader" "writer")
759 (list
760 (slot-definition-initargs slot)
761 (slot-definition-readers slot)
762 (slot-definition-writers slot)))))
763 ;; FIXME: Would be neater to handler as children
764 (write-texinfo-string (docstring slot t)))
765 (format *texinfo-output* "@end itemize~%~%"))))))
766
767 (defun texinfo-body (doc)
768 (write-texinfo-string (get-string doc)))
769
770 (defun texinfo-end (doc)
771 (write-line (case (get-kind doc)
772 ((package variable constant) "@end defvr")
773 ((structure type class condition) "@end deftp")
774 (t "@end deffn"))
775 *texinfo-output*))
776
777 (defun write-texinfo (doc)
778 "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
779 (texinfo-anchor doc)
780 (texinfo-begin doc)
781 (texinfo-index doc)
782 (texinfo-inferred-body doc)
783 (texinfo-body doc)
784 (texinfo-end doc)
785 ;; FIXME: Children should be sorted one way or another
786 (mapc #'write-texinfo (get-children doc)))
787
788 ;;;; main logic
789
790 (defun collect-gf-documentation (gf)
791 "Collects method documentation for the generic function GF"
792 (loop for method in (generic-function-methods gf)
793 for doc = (maybe-documentation method t)
794 when doc
795 collect doc))
796
797 (defun collect-name-documentation (name)
798 (loop for type in *documentation-types*
799 for doc = (maybe-documentation name type)
800 when doc
801 collect doc))
802
803 (defun collect-symbol-documentation (symbol)
804 "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
805 the form DOC instances. See `*documentation-types*' for the possible
806 values of doc-type."
807 (nconc (collect-name-documentation symbol)
808 (collect-name-documentation (list 'setf symbol))))
809
810 (defun collect-documentation (package)
811 "Collects all documentation for all external symbols of the given
812 package, as well as for the package itself."
813 (let* ((*documentation-package* (find-package package))
814 (docs nil))
815 (check-type package package)
816 (do-external-symbols (symbol package)
817 (setf docs (nconc (collect-symbol-documentation symbol) docs)))
818 (let ((doc (maybe-documentation *documentation-package* t)))
819 (when doc
820 (push doc docs)))
821 docs))
822
823 (defmacro with-texinfo-file (pathname &body forms)
824 `(with-open-file (*texinfo-output* ,pathname
825 :direction :output
826 :if-does-not-exist :create
827 :if-exists :supersede)
828 ,@forms))
829
830 (defun write-ifnottex ()
831 ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
832 ;; define them for info as well.
833 (flet ((macro (name)
834 (let ((string (string-downcase name)))
835 (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string))))
836 (macro '&allow-other-keys)
837 (macro '&optional)
838 (macro '&rest)
839 (macro '&key)
840 (macro '&body)))
841
842 (defun generate-includes (directory packages &key (base-package :cl-user))
843 "Create files in `directory' containing Texinfo markup of all
844 docstrings of each exported symbol in `packages'. `directory' is
845 created if necessary. If you supply a namestring that doesn't end in a
846 slash, you lose. The generated files are of the form
847 \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
848 via @include statements. Texinfo syntax-significant characters are
849 escaped in symbol names, but if a docstring contains invalid Texinfo
850 markup, you lose."
851 (handler-bind ((warning #'muffle-warning))
852 (let ((directory (merge-pathnames (pathname directory)))
853 (*base-package* (find-package base-package)))
854 (ensure-directories-exist directory)
855 (dolist (package packages)
856 (dolist (doc (collect-documentation (find-package package)))
857 (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
858 (write-texinfo doc))))
859 (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
860 (write-ifnottex))
861 directory)))
862
863 (defun document-package (package &optional filename)
864 "Create a file containing all available documentation for the
865 exported symbols of `package' in Texinfo format. If `filename' is not
866 supplied, a file \"<packagename>.texinfo\" is generated.
867
868 The definitions can be referenced using Texinfo statements like
869 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
870 syntax-significant characters are escaped in symbol names, but if a
871 docstring contains invalid Texinfo markup, you lose."
872 (handler-bind ((warning #'muffle-warning))
873 (let* ((package (find-package package))
874 (filename (or filename (make-pathname
875 :name (string-downcase (short-package-name package))
876 :type "texinfo")))
877 (docs (sort (collect-documentation package) #'documentation<)))
878 (with-texinfo-file filename
879 (dolist (doc docs)
880 (write-texinfo doc)))
881 filename)))