docstrings.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
docstrings.lisp (35547B)
---
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 (defun short-name-for-symbol (symbol &optional (package *base-package*))
206 "Given a SYMBOL, return its name if it's available in PACKAGE,
207 or PACKAGE:SYMBOL otherwise."
208 (format nil "~@[~a:~]~a"
209 (unless (eq symbol
210 (find-symbol (symbol-name symbol)
211 package))
212 (shortest-package-name (symbol-package symbol)))
213 (symbol-name symbol)))
214
215 (defgeneric name-using-kind/name (kind name doc))
216
217 (defmethod name-using-kind/name (kind (name string) doc)
218 (declare (ignore kind doc))
219 name)
220
221 (defmethod name-using-kind/name (kind (name symbol) doc)
222 (declare (ignore kind))
223 (short-name-for-symbol name))
224
225 (defmethod name-using-kind/name (kind (name list) doc)
226 (declare (ignore kind))
227 (assert (setf-name-p name))
228 (let ((name (short-name-for-symbol (second name))))
229 (format nil "(setf ~A)" name)))
230
231 (defmethod name-using-kind/name ((kind (eql 'method)) name doc)
232 (format nil "~A~{ ~A~} ~A"
233 (name-using-kind/name nil (first name) doc)
234 (second name)
235 (third name)))
236
237 (defun node-name (doc)
238 "Returns TexInfo node name as a string for a DOCUMENTATION instance."
239 (let ((kind (get-kind doc)))
240 (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
241
242 (defun shortest-package-name (package)
243 (car (sort (copy-list (cons (package-name package) (package-nicknames package)))
244 #'< :key #'length)))
245
246 (defun short-package-name (package)
247 (unless (eq package *base-package*)
248 (shortest-package-name package)))
249
250
251 ;;; Definition titles for DOCUMENTATION instances
252
253 (defgeneric title-using-kind/name (kind name doc))
254
255 (defmethod title-using-kind/name (kind (name string) doc)
256 (declare (ignore kind doc))
257 name)
258
259 (defmethod title-using-kind/name (kind (name symbol) doc)
260 (declare (ignore kind))
261 (short-name-for-symbol name))
262
263 (defmethod title-using-kind/name (kind (name list) doc)
264 (declare (ignore kind))
265 (assert (setf-name-p name))
266 (format nil "(setf ~A)" (short-name-for-symbol (second name))))
267
268 (defmethod title-using-kind/name ((kind (eql 'method)) name doc)
269 (format nil "~{~A ~}~A"
270 (second name)
271 (title-using-kind/name nil (first name) doc)))
272
273 (defun title-name (doc)
274 "Returns a string to be used as name of the definition."
275 (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
276
277 (defun include-pathname (doc)
278 (let* ((kind (get-kind doc))
279 (name (nstring-downcase
280 (if (eq 'package kind)
281 (format nil "package-~A" (alphanumize (get-name doc)))
282 (format nil "~A-~A-~A"
283 (case (get-kind doc)
284 ((function generic-function) "fun")
285 (structure "struct")
286 (variable "var")
287 (otherwise (symbol-name (get-kind doc))))
288 (alphanumize (let ((*base-package* nil))
289 (short-package-name (get-package doc))))
290 (alphanumize (get-name doc)))))))
291 (make-pathname :name name :type "texinfo")))
292
293 ;;;; documentation class and related methods
294
295 (defclass documentation ()
296 ((name :initarg :name :reader get-name)
297 (kind :initarg :kind :reader get-kind)
298 (string :initarg :string :reader get-string)
299 (children :initarg :children :initform nil :reader get-children)
300 (package :initform *documentation-package* :reader get-package)))
301
302 (defmethod print-object ((documentation documentation) stream)
303 (print-unreadable-object (documentation stream :type t)
304 (princ (list (get-kind documentation) (get-name documentation)) stream)))
305
306 (defgeneric make-documentation (x doc-type string))
307
308 (defmethod make-documentation ((x package) doc-type string)
309 (declare (ignore doc-type))
310 (make-instance 'documentation
311 :name (name x)
312 :kind 'package
313 :string string))
314
315 (defmethod make-documentation (x (doc-type (eql 'function)) string)
316 (declare (ignore doc-type))
317 (let* ((fdef (and (fboundp x) (fdefinition x)))
318 (name x)
319 (kind (cond ((and (symbolp x) (special-operator-p x))
320 'special-operator)
321 ((and (symbolp x) (macro-function x))
322 'macro)
323 ((typep fdef 'generic-function)
324 (assert (or (symbolp name) (setf-name-p name)))
325 'generic-function)
326 (fdef
327 (assert (or (symbolp name) (setf-name-p name)))
328 'function)))
329 (children (when (eq kind 'generic-function)
330 (collect-gf-documentation fdef))))
331 (make-instance 'documentation
332 :name (name x)
333 :string string
334 :kind kind
335 :children children)))
336
337 (defmethod make-documentation ((x method) doc-type string)
338 (declare (ignore doc-type))
339 (make-instance 'documentation
340 :name (name x)
341 :kind 'method
342 :string string))
343
344 (defmethod make-documentation (x (doc-type (eql 'type)) string)
345 (make-instance 'documentation
346 :name (name x)
347 :string string
348 :kind (etypecase (find-class x nil)
349 (structure-class 'structure)
350 (standard-class 'class)
351 (sb-pcl::condition-class 'condition)
352 ((or built-in-class null) 'type))))
353
354 (defmethod make-documentation (x (doc-type (eql 'variable)) string)
355 (make-instance 'documentation
356 :name (name x)
357 :string string
358 :kind (if (constantp x)
359 'constant
360 'variable)))
361
362 (defmethod make-documentation (x (doc-type (eql 'setf)) string)
363 (declare (ignore doc-type))
364 (make-instance 'documentation
365 :name (name x)
366 :kind 'setf-expander
367 :string string))
368
369 (defmethod make-documentation (x doc-type string)
370 (make-instance 'documentation
371 :name (name x)
372 :kind doc-type
373 :string string))
374
375 (defun maybe-documentation (x doc-type)
376 "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
377 there is no corresponding docstring."
378 (let ((docstring (docstring x doc-type)))
379 (when docstring
380 (make-documentation x doc-type docstring))))
381
382 (defun lambda-list (doc)
383 (case (get-kind doc)
384 ((package constant variable type structure class condition nil)
385 nil)
386 (method
387 (third (get-name doc)))
388 (t
389 ;; KLUDGE: Eugh.
390 ;;
391 ;; believe it or not, the above comment was written before CSR
392 ;; came along and obfuscated this. (2005-07-04)
393 (when (symbolp (get-name doc))
394 (labels ((clean (x &key optional key)
395 (typecase x
396 (atom x)
397 ((cons (member &optional))
398 (cons (car x) (clean (cdr x) :optional t)))
399 ((cons (member &key))
400 (cons (car x) (clean (cdr x) :key t)))
401 ((cons (member &whole &environment))
402 ;; Skip these
403 (clean (cdr x) :optional optional :key key))
404 ((cons cons)
405 (cons
406 (cond (key (if (consp (caar x))
407 (caaar x)
408 (caar x)))
409 (optional (caar x))
410 (t (clean (car x))))
411 (clean (cdr x) :key key :optional optional)))
412 (cons
413 (cons
414 (cond ((or key optional) (car x))
415 (t (clean (car x))))
416 (clean (cdr x) :key key :optional optional))))))
417 (clean (sb-introspect:function-lambda-list (get-name doc))))))))
418
419 (defun get-string-name (x)
420 (let ((name (get-name x)))
421 (cond ((symbolp name)
422 (symbol-name name))
423 ((and (consp name) (eq 'setf (car name)))
424 (symbol-name (second name)))
425 ((stringp name)
426 name)
427 (t
428 (error "Don't know which symbol to use for name ~S" name)))))
429
430 (defun documentation< (x y)
431 (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
432 (p2 (position (get-kind y) *ordered-documentation-kinds*)))
433 (if (or (not (and p1 p2)) (= p1 p2))
434 (string< (get-string-name x) (get-string-name y))
435 (< p1 p2))))
436
437 ;;;; turning text into texinfo
438
439 (defun escape-for-texinfo (string &optional downcasep)
440 "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
441 with #\@. Optionally downcase the result."
442 (let ((result (with-output-to-string (s)
443 (loop for char across string
444 when (find char *texinfo-escaped-chars*)
445 do (write-char #\@ s)
446 do (write-char char s)))))
447 (if downcasep (nstring-downcase result) result)))
448
449 (defun empty-p (line-number lines)
450 (and (< -1 line-number (length lines))
451 (not (indentation (svref lines line-number)))))
452
453 ;;; line markups
454
455 (defvar *not-symbols* '("ANSI" "CLHS"))
456
457 (defun locate-symbols (line)
458 "Return a list of index pairs of symbol-like parts of LINE."
459 ;; This would be a good application for a regex ...
460 (let (result)
461 (flet ((grab (start end)
462 (unless (member (subseq line start end) '("ANSI" "CLHS"))
463 (push (list start end) result))))
464 (do ((begin nil)
465 (maybe-begin t)
466 (i 0 (1+ i)))
467 ((= i (length line))
468 ;; symbol at end of line
469 (when (and begin (or (> i (1+ begin))
470 (not (member (char line begin) '(#\A #\I)))))
471 (grab begin i))
472 (nreverse result))
473 (cond
474 ((and begin (find (char line i) *symbol-delimiters*))
475 ;; symbol end; remember it if it's not "A" or "I"
476 (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
477 (grab begin i))
478 (setf begin nil
479 maybe-begin t))
480 ((and begin (not (find (char line i) *symbol-characters*)))
481 ;; Not a symbol: abort
482 (setf begin nil))
483 ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
484 ;; potential symbol begin at this position
485 (setf begin i
486 maybe-begin nil))
487 ((find (char line i) *symbol-delimiters*)
488 ;; potential symbol begin after this position
489 (setf maybe-begin t))
490 (t
491 ;; Not reading a symbol, not at potential start of symbol
492 (setf maybe-begin nil)))))))
493
494 (defun texinfo-line (line)
495 "Format symbols in LINE texinfo-style: either as code or as
496 variables if the symbol in question is contained in symbols
497 *TEXINFO-VARIABLES*."
498 (with-output-to-string (result)
499 (let ((last 0))
500 (dolist (symbol/index (locate-symbols line))
501 (write-string (subseq line last (first symbol/index)) result)
502 (let ((symbol-name (apply #'subseq line symbol/index)))
503 (format result (if (member symbol-name *texinfo-variables*
504 :test #'string=)
505 "@var{~A}"
506 "@code{~A}")
507 (string-downcase symbol-name)))
508 (setf last (second symbol/index)))
509 (write-string (subseq line last) result))))
510
511 ;;; lisp sections
512
513 (defun lisp-section-p (line line-number lines)
514 "Returns T if the given LINE looks like start of lisp code --
515 ie. if it starts with whitespace followed by a paren or
516 semicolon, and the previous line is empty"
517 (let ((offset (indentation line)))
518 (and offset
519 (plusp offset)
520 (find (find-if-not #'whitespacep line) "(;")
521 (empty-p (1- line-number) lines))))
522
523 (defun collect-lisp-section (lines line-number)
524 (let ((lisp (loop for index = line-number then (1+ index)
525 for line = (and (< index (length lines)) (svref lines index))
526 while (indentation line)
527 collect line)))
528 (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
529
530 ;;; itemized sections
531
532 (defun maybe-itemize-offset (line)
533 "Return NIL or the indentation offset if LINE looks like it starts
534 an item in an itemization."
535 (let* ((offset (indentation line))
536 (char (when offset (char line offset))))
537 (and offset
538 (member char *itemize-start-characters* :test #'char=)
539 (char= #\Space (find-if-not (lambda (c) (char= c char))
540 line :start offset))
541 offset)))
542
543 (defun collect-maybe-itemized-section (lines starting-line)
544 ;; Return index of next line to be processed outside
545 (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
546 (result nil)
547 (lines-consumed 0))
548 (loop for line-number from starting-line below (length lines)
549 for line = (svref lines line-number)
550 for indentation = (indentation line)
551 for offset = (maybe-itemize-offset line)
552 do (cond
553 ((not indentation)
554 ;; empty line -- inserts paragraph.
555 (push "" result)
556 (incf lines-consumed))
557 ((and offset (> indentation this-offset))
558 ;; nested itemization -- handle recursively
559 ;; FIXME: tables in itemizations go wrong
560 (multiple-value-bind (sub-lines-consumed sub-itemization)
561 (collect-maybe-itemized-section lines line-number)
562 (when sub-lines-consumed
563 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
564 (incf lines-consumed sub-lines-consumed)
565 (setf result (nconc (nreverse sub-itemization) result)))))
566 ((and offset (= indentation this-offset))
567 ;; start of new item
568 (push (format nil "@item ~A"
569 (texinfo-line (subseq line (1+ offset))))
570 result)
571 (incf lines-consumed))
572 ((and (not offset) (> indentation this-offset))
573 ;; continued item from previous line
574 (push (texinfo-line line) result)
575 (incf lines-consumed))
576 (t
577 ;; end of itemization
578 (loop-finish))))
579 ;; a single-line itemization isn't.
580 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
581 (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
582 nil)))
583
584 ;;; table sections
585
586 (defun tabulation-body-p (offset line-number lines)
587 (when (< line-number (length lines))
588 (let ((offset2 (indentation (svref lines line-number))))
589 (and offset2 (< offset offset2)))))
590
591 (defun tabulation-p (offset line-number lines direction)
592 (let ((step (ecase direction
593 (:backwards (1- line-number))
594 (:forwards (1+ line-number)))))
595 (when (and (plusp line-number) (< line-number (length lines)))
596 (and (eql offset (indentation (svref lines line-number)))
597 (or (when (eq direction :backwards)
598 (empty-p step lines))
599 (tabulation-p offset step lines direction)
600 (tabulation-body-p offset step lines))))))
601
602 (defun maybe-table-offset (line-number lines)
603 "Return NIL or the indentation offset if LINE looks like it starts
604 an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
605 empty line, another tabulation label, or a tabulation body, (3) and
606 followed another tabulation label or a tabulation body."
607 (let* ((line (svref lines line-number))
608 (offset (indentation line))
609 (prev (1- line-number))
610 (next (1+ line-number)))
611 (when (and offset (plusp offset))
612 (and (or (empty-p prev lines)
613 (tabulation-body-p offset prev lines)
614 (tabulation-p offset prev lines :backwards))
615 (or (tabulation-body-p offset next lines)
616 (tabulation-p offset next lines :forwards))
617 offset))))
618
619 ;;; FIXME: This and itemization are very similar: could they share
620 ;;; some code, mayhap?
621
622 (defun collect-maybe-table-section (lines starting-line)
623 ;; Return index of next line to be processed outside
624 (let ((this-offset (maybe-table-offset starting-line lines))
625 (result nil)
626 (lines-consumed 0))
627 (loop for line-number from starting-line below (length lines)
628 for line = (svref lines line-number)
629 for indentation = (indentation line)
630 for offset = (maybe-table-offset line-number lines)
631 do (cond
632 ((not indentation)
633 ;; empty line -- inserts paragraph.
634 (push "" result)
635 (incf lines-consumed))
636 ((and offset (= indentation this-offset))
637 ;; start of new item, or continuation of previous item
638 (if (and result (search "@item" (car result) :test #'char=))
639 (push (format nil "@itemx ~A" (texinfo-line line))
640 result)
641 (progn
642 (push "" result)
643 (push (format nil "@item ~A" (texinfo-line line))
644 result)))
645 (incf lines-consumed))
646 ((> indentation this-offset)
647 ;; continued item from previous line
648 (push (texinfo-line line) result)
649 (incf lines-consumed))
650 (t
651 ;; end of itemization
652 (loop-finish))))
653 ;; a single-line table isn't.
654 (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
655 (values lines-consumed
656 `("" "@table @emph" ,@(reverse result) "@end table" ""))
657 nil)))
658
659 ;;; section markup
660
661 (defmacro with-maybe-section (index &rest forms)
662 `(multiple-value-bind (count collected) (progn ,@forms)
663 (when count
664 (dolist (line collected)
665 (write-line line *texinfo-output*))
666 (incf ,index (1- count)))))
667
668 (defun write-texinfo-string (string &optional lambda-list)
669 "Try to guess as much formatting for a raw docstring as possible."
670 (let ((*texinfo-variables* (flatten lambda-list))
671 (lines (string-lines (escape-for-texinfo string nil))))
672 (loop for line-number from 0 below (length lines)
673 for line = (svref lines line-number)
674 do (cond
675 ((with-maybe-section line-number
676 (and (lisp-section-p line line-number lines)
677 (collect-lisp-section lines line-number))))
678 ((with-maybe-section line-number
679 (and (maybe-itemize-offset line)
680 (collect-maybe-itemized-section lines line-number))))
681 ((with-maybe-section line-number
682 (and (maybe-table-offset line-number lines)
683 (collect-maybe-table-section lines line-number))))
684 (t
685 (write-line (texinfo-line line) *texinfo-output*))))))
686
687 ;;;; texinfo formatting tools
688
689 (defun hide-superclass-p (class-name super-name)
690 (let ((super-package (symbol-package super-name)))
691 (or
692 ;; KLUDGE: We assume that we don't want to advertise internal
693 ;; classes in CP-lists, unless the symbol we're documenting is
694 ;; internal as well.
695 (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
696 (not (eq super-package (symbol-package class-name))))
697 ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
698 ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
699 ;; simply as a matter of convenience. The assumption here is that
700 ;; the inheritance is incidental unless the name of the condition
701 ;; begins with SIMPLE-.
702 (and (member super-name '(simple-error simple-condition))
703 (let ((prefix "SIMPLE-"))
704 (mismatch prefix (string class-name) :end2 (length prefix)))
705 t ; don't return number from MISMATCH
706 ))))
707
708 (defun hide-slot-p (symbol slot)
709 ;; FIXME: There is no pricipal reason to avoid the slot docs fo
710 ;; structures and conditions, but their DOCUMENTATION T doesn't
711 ;; currently work with them the way we'd like.
712 (not (and (typep (find-class symbol nil) 'standard-class)
713 (docstring slot t))))
714
715 (defun texinfo-anchor (doc)
716 (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
717
718 ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
719 (defun texinfo-begin (doc &aux *print-pretty*)
720 (let ((kind (get-kind doc)))
721 (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%"
722 (case kind
723 ((package constant variable)
724 "defvr")
725 ((structure class condition type)
726 "deftp")
727 (t
728 "deffn"))
729 (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
730 (title-name doc)
731 ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo
732 ;; interactions,so we escape the ampersand -- amusingly for TeX.
733 ;; sbcl.texinfo defines macros that expand @&key and friends to &key.
734 (mapcar (lambda (name)
735 (if (member name lambda-list-keywords)
736 (format nil "@~A" name)
737 name))
738 (lambda-list doc)))))
739
740 (defun texinfo-index (doc)
741 (let ((title (title-name doc)))
742 (case (get-kind doc)
743 ((structure type class condition)
744 (format *texinfo-output* "@tindex ~A~%" title))
745 ((variable constant)
746 (format *texinfo-output* "@vindex ~A~%" title))
747 ((compiler-macro function method-combination macro generic-function)
748 (format *texinfo-output* "@findex ~A~%" title)))))
749
750 (defun texinfo-inferred-body (doc)
751 (when (member (get-kind doc) '(class structure condition))
752 (let ((name (get-name doc)))
753 ;; class precedence list
754 (format *texinfo-output* "Class precedence list: @code{~(~{@lw{~A}~^, ~}~)}~%~%"
755 (remove-if (lambda (class) (hide-superclass-p name class))
756 (mapcar #'class-name (ensure-class-precedence-list (find-class name)))))
757 ;; slots
758 (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
759 (class-direct-slots (find-class name)))))
760 (when slots
761 (format *texinfo-output* "Slots:~%@itemize~%")
762 (dolist (slot slots)
763 (format *texinfo-output*
764 "@item ~(@code{~A}~#[~:; --- ~]~
765 ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%"
766 (slot-definition-name slot)
767 (remove
768 nil
769 (mapcar
770 (lambda (name things)
771 (if things
772 (list name (length things) things)))
773 '("initarg" "reader" "writer")
774 (list
775 (slot-definition-initargs slot)
776 (slot-definition-readers slot)
777 (slot-definition-writers slot)))))
778 ;; FIXME: Would be neater to handler as children
779 (write-texinfo-string (docstring slot t)))
780 (format *texinfo-output* "@end itemize~%~%"))))))
781
782 (defun texinfo-body (doc)
783 (write-texinfo-string (get-string doc)))
784
785 (defun texinfo-end (doc)
786 (write-line (case (get-kind doc)
787 ((package variable constant) "@end defvr")
788 ((structure type class condition) "@end deftp")
789 (t "@end deffn"))
790 *texinfo-output*))
791
792 (defun write-texinfo (doc)
793 "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
794 (texinfo-anchor doc)
795 (texinfo-begin doc)
796 (texinfo-index doc)
797 (texinfo-inferred-body doc)
798 (texinfo-body doc)
799 (texinfo-end doc)
800 ;; FIXME: Children should be sorted one way or another
801 (mapc #'write-texinfo (get-children doc)))
802
803 ;;;; main logic
804
805 (defun collect-gf-documentation (gf)
806 "Collects method documentation for the generic function GF"
807 (loop for method in (generic-function-methods gf)
808 for doc = (maybe-documentation method t)
809 when doc
810 collect doc))
811
812 (defun collect-name-documentation (name)
813 (loop for type in *documentation-types*
814 for doc = (maybe-documentation name type)
815 when doc
816 collect doc))
817
818 (defun collect-symbol-documentation (symbol)
819 "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
820 the form DOC instances. See `*documentation-types*' for the possible
821 values of doc-type."
822 (nconc (collect-name-documentation symbol)
823 (collect-name-documentation (list 'setf symbol))))
824
825 (defun collect-documentation (package &optional ht)
826 "Collects all documentation for all external symbols of the given
827 package, as well as for the package itself."
828 (let* ((*documentation-package* (find-package package))
829 (docs nil))
830 (check-type package package)
831 (do-external-symbols (symbol package)
832 (unless (and ht
833 (nth-value 1 (alexandria:ensure-gethash symbol ht t)))
834 (setf (gethash symbol ht) t)
835 (setf docs (nconc (collect-symbol-documentation symbol) docs))))
836 (let ((doc (maybe-documentation *documentation-package* t)))
837 (when doc
838 (push doc docs)))
839 docs))
840
841 (defmacro with-texinfo-file (pathname &body forms)
842 `(with-open-file (*texinfo-output* ,pathname
843 :direction :output
844 :if-does-not-exist :create
845 :if-exists :supersede)
846 ,@forms))
847
848 (defun write-ifnottex ()
849 ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to
850 ;; define them for info as well.
851 ;; Texinfo > 5 doesn't allow "&" in macro names any more;
852 ;; see also https://bugs.launchpad.net/asdf/+bug/1172567 or
853 ;; ASDF commit dfa4643b212b194f2d673b6f0d9c7d4b19d823ba
854 (flet ((macro (name)
855 (let ((string (string-downcase name)))
856 (format *texinfo-output* "@macro ~A~%&~A~%@end macro~%" string string))))
857 (macro 'allow-other-keys)
858 (macro 'optional)
859 (macro 'rest)
860 (macro 'key)
861 (macro 'body)))
862
863 (defun generate-includes (directory packages &key (base-package :cl-user))
864 "Create files in `directory' containing Texinfo markup of all
865 docstrings of each exported symbol in `packages'. `directory' is
866 created if necessary. If you supply a namestring that doesn't end in a
867 slash, you lose. The generated files are of the form
868 \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included
869 via @include statements. Texinfo syntax-significant characters are
870 escaped in symbol names, but if a docstring contains invalid Texinfo
871 markup, you lose."
872 (handler-bind ((warning #'muffle-warning))
873 (let* ((directory (merge-pathnames (pathname directory)))
874 (*base-package* (find-package base-package))
875 (syms-seen (make-hash-table :test #'eq)))
876 (ensure-directories-exist directory)
877 (dolist (package packages)
878 (dolist (doc (collect-documentation (find-package package) syms-seen))
879 (with-texinfo-file (merge-pathnames (include-pathname doc) directory)
880 (write-texinfo doc))))
881 (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory)
882 (write-ifnottex))
883 directory)))
884
885 (defun document-package (package &optional filename)
886 "Create a file containing all available documentation for the
887 exported symbols of `package' in Texinfo format. If `filename' is not
888 supplied, a file \"<packagename>.texinfo\" is generated.
889
890 The definitions can be referenced using Texinfo statements like
891 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
892 syntax-significant characters are escaped in symbol names, but if a
893 docstring contains invalid Texinfo markup, you lose."
894 (handler-bind ((warning #'muffle-warning))
895 (let* ((package (find-package package))
896 (filename (or filename (make-pathname
897 :name (string-downcase (short-package-name package))
898 :type "texinfo")))
899 (docs (sort (collect-documentation package) #'documentation<)))
900 (with-texinfo-file filename
901 (dolist (doc docs)
902 (write-texinfo doc)))
903 filename)))