docstrings.lisp - clic - Clic is an command line interactive client for gopher … | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[email protected]>, 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 a… | |
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 s… | |
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-re… | |
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-na… | |
241 | |
242 (defun shortest-package-name (package) | |
243 (car (sort (copy-list (cons (package-name package) (package-nicknames … | |
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) … | |
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-pack… | |
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)) stre… | |
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) '(#… | |
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-char… | |
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 line… | |
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… | |
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 ite… | |
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 #'cha… | |
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-numb… | |
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-… | |
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)… | |
730 (title-name doc) | |
731 ;; &foo would be amusingly bold in the pdf thanks to TeX/Tex… | |
732 ;; interactions,so we escape the ampersand -- amusingly for … | |
733 ;; sbcl.texinfo defines macros that expand @&key and friends… | |
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-functio… | |
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-l… | |
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 nee… | |
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~… | |
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-… | |
879 (with-texinfo-file (merge-pathnames (include-pathname doc) dir… | |
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… | |
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))) |