3 ;;;; A docstring extractor for the sbcl manual. Creates
4 ;;;; @include-ready documentation from the docstrings of exported
5 ;;;; symbols of specified packages.
8 ;;;; This software is part of the SBCL software system. SBCL is in the
9 ;;;; public domain and is provided with absolutely no warranty. See
10 ;;;; the COPYING file for more information.
12 ;;;; Written by Rudi Schlatte <rudi@constantly.at>
15 ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely):
17 ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in
18 ;;;; the argument list of the defun / defmacro.
20 ;;;; Lines starting with * or - that are followed by intented lines
21 ;;;; are marked up with @itemize.
23 ;;;; Lines containing only a SYMBOL that are followed by indented
24 ;;;; lines are marked up as @table @code, with the SYMBOL as the item.
28 (eval-when (:compile-toplevel :load-toplevel :execute)
29 (require 'sb-introspect))
31 (defparameter *documentation-types*
36 ;;structure ; also handled by `type'
39 "A list of symbols accepted as second argument of `documentation'")
41 ;;; Collecting info from package
43 (defun documentation-for-symbol (symbol)
44 "Collects all doc for a symbol, returns a list of the
45 form (symbol doc-type docstring). See `*documentation-types*'
46 for the possible values of doc-type."
47 (loop for kind in *documentation-types*
48 for doc = (documentation symbol kind)
50 collect (list symbol kind doc)))
52 (defun collect-documentation (package)
53 "Collects all documentation for all external symbols of the
54 given package, as well as for the package itself."
55 (let* ((package (find-package package))
56 (package-doc (documentation package t))
58 (check-type package package)
59 (do-external-symbols (symbol package)
60 (let ((docs (documentation-for-symbol symbol)))
61 (when docs (setf result (nconc docs result)))))
63 (setf result (nconc (list (list (intern (package-name package) :keyword)
64 'package package-doc)) result)))
67 ;;; Helpers for texinfo output
69 (defvar *texinfo-escaped-chars* "@{}"
70 "Characters that must be escaped with #\@ for Texinfo.")
72 (defun texinfoify (string-designator &optional (downcase-p t))
73 "Return 'string-designator' with characters in
74 *texinfo-escaped-chars* escaped with #\@. Optionally downcase
76 (let ((result (with-output-to-string (s)
77 (loop for char across (string string-designator)
78 when (find char *texinfo-escaped-chars*)
80 do (write-char char s)))))
81 (if downcase-p (nstring-downcase result) result)))
83 (defvar *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+"
84 "List of characters that make up symbols in a docstring.")
86 (defvar *symbol-delimiters* " ,.!?;")
88 (defun locate-symbols (line)
89 "Return a list of index pairs of symbol-like parts of LINE."
90 ;; This would be a good application for a regex ...
96 ;; symbol at end of line
97 (when (and begin (or (> i (1+ begin))
98 (not (member (char line begin) '(#\A #\I)))))
99 (push (list begin i) result))
102 ((and begin (find (char line i) *symbol-delimiters*))
103 ;; symbol end; remember it if it's not "A" or "I"
104 (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
105 (push (list begin i) result))
108 ((and begin (not (find (char line i) *symbol-characters*)))
109 ;; Not a symbol: abort
111 ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
112 ;; potential symbol begin at this position
115 ((find (char line i) *symbol-delimiters*)
116 ;; potential symbol begin after this position
117 (setf maybe-begin t))
119 ;; Not reading a symbol, not at potential start of symbol
120 (setf maybe-begin nil)))))
122 (defun all-symbols (list)
123 (cond ((null list) nil)
124 ((symbolp list) (list list))
125 ((consp list) (append (all-symbols (car list))
126 (all-symbols (cdr list))))
130 (defun frob-doc-line (line var-symbols)
131 "Format symbols in LINE texinfo-style: either as code or as
132 variables if the symbol in question is contained in
134 (with-output-to-string (result)
136 (dolist (symbol-index (locate-symbols line))
137 (write-string (subseq line last (first symbol-index)) result)
138 (let ((symbol-name (apply #'subseq line symbol-index)))
139 (format result (if (member symbol-name var-symbols
143 (string-downcase symbol-name)))
144 (setf last (second symbol-index)))
145 (write-string (subseq line last) result))))
147 (defparameter *itemize-start-characters* '(#\* #\-)
148 "Characters that might start an itemization in docstrings when
149 at the start of a line.")
151 (defun indentation (line)
152 "Position of first non-SPACE character in LINE."
153 (position-if-not (lambda (c) (char= c #\Space)) line))
155 (defun maybe-itemize-offset (line)
156 "Return NIL or the indentation offset if LINE looks like it
157 starts an item in an itemization."
158 (let ((offset (indentation line)))
160 (member (char line offset) *itemize-start-characters*
164 (defun collect-maybe-itemized-section (lines starting-line arglist-symbols)
165 ;; Return index of next line to be processed outside
166 (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
169 (loop for line-number from starting-line below (length lines)
170 for line = (svref lines line-number)
171 for indentation = (indentation line)
172 for offset = (maybe-itemize-offset line)
175 ;; empty line -- inserts paragraph.
177 (incf lines-consumed))
178 ((and offset (> indentation this-offset))
179 ;; nested itemization -- handle recursively
180 (multiple-value-bind (sub-lines-consumed sub-itemization)
181 (collect-maybe-itemized-section lines line-number
183 (when sub-lines-consumed
184 (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
185 (incf lines-consumed sub-lines-consumed)
186 (setf result (nconc (nreverse sub-itemization) result)))))
187 ((and offset (= indentation this-offset))
189 (push (format nil "@item ~A"
190 (frob-doc-line (subseq line (1+ offset))
193 (incf lines-consumed))
194 ((and (not offset) (> indentation this-offset))
195 ;; continued item from previous line
196 (push (frob-doc-line line arglist-symbols) result)
197 (incf lines-consumed))
199 ;; end of itemization
202 ;; a single-line itemization isn't.
203 (> (count-if (lambda (line) (> (length line) 0)) result) 1)
204 (values lines-consumed
205 `("@itemize" ,@(reverse result) "@end itemize"))
209 (defun maybe-table-offset (line)
210 "Return NIL or the indentation offset if LINE looks like it
211 starts an item in a tabulation, i.e., there's only a symbol on the line."
212 (let ((offset (indentation line)))
215 (or (char= c #\Space)
216 (find c *symbol-characters* :test #'char=)))
221 (defun collect-maybe-table-section (lines starting-line arglist-symbols)
222 ;; Return index of next line to be processed outside
223 (let ((this-offset (maybe-table-offset (svref lines starting-line)))
226 (loop for line-number from starting-line below (length lines)
227 for line = (svref lines line-number)
228 for indentation = (indentation line)
229 for offset = (maybe-table-offset line)
232 ;; empty line -- inserts paragraph.
234 (incf lines-consumed))
235 ((and offset (= indentation this-offset))
236 ;; start of new item, or continuation of previous item
237 (if (and result (search "@item" (car result) :test #'char=))
238 (push (format nil "@itemx ~A"
239 (frob-doc-line line arglist-symbols))
243 (push (format nil "@item ~A"
244 (frob-doc-line line arglist-symbols))
246 (incf lines-consumed))
247 ((> indentation this-offset)
248 ;; continued item from previous line
249 (push (frob-doc-line line arglist-symbols) result)
250 (incf lines-consumed))
252 ;; end of itemization
255 ;; a single-line table isn't.
256 (> (count-if (lambda (line) (> (length line) 0)) result) 1)
257 (values lines-consumed
258 `("" "@table @code" ,@(reverse result) "@end table" ""))
264 (defun string-as-lines (string)
265 (coerce (with-input-from-string (s string)
266 (loop for line = (read-line s nil nil)
267 while line collect line))
270 (defun frob-docstring (docstring symbol-arglist)
271 "Try to guess as much formatting for a raw docstring as possible."
272 ;; Per-line processing is not necessary now, but it will be when we
273 ;; attempt itemize / table auto-detection in docstrings
274 (with-output-to-string (result)
275 (let ((arglist-symbols (all-symbols symbol-arglist))
276 (doc-lines (string-as-lines (texinfoify docstring nil))))
277 (loop for line-number from 0 below (length doc-lines)
278 for line = (svref doc-lines line-number)
280 ((maybe-itemize-offset line)
281 (multiple-value-bind (lines-consumed itemized-lines)
282 (collect-maybe-itemized-section doc-lines line-number
284 (cond (lines-consumed
285 (dolist (item-line itemized-lines)
286 (write-line item-line result))
287 (incf line-number (1- lines-consumed)))
288 (t (write-line (frob-doc-line line arglist-symbols)
290 ((maybe-table-offset line)
291 (multiple-value-bind (lines-consumed itemized-lines)
292 (collect-maybe-table-section doc-lines line-number
294 (cond (lines-consumed
295 (dolist (item-line itemized-lines)
296 (write-line item-line result))
297 (incf line-number (1- lines-consumed)))
298 (t (write-line (frob-doc-line line arglist-symbols)
300 (t (write-line (frob-doc-line line arglist-symbols) result)))))))
302 ;;; Begin, rest and end of definition.
304 (defun argument-list (fname)
305 (sb-introspect:function-arglist fname))
307 (defvar *character-replacements*
308 '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
309 "Characters and their replacement names that `alphanumize'
310 uses. If the replacements contain any of the chars they're
311 supposed to replace, you deserve to lose.")
313 (defvar *characters-to-drop* '(#\\ #\` #\')
314 "Characters that should be removed by `alphanumize'.")
317 (defun alphanumize (symbol)
318 "Construct a string without characters like *`' that will
319 f-star-ck up filename handling. See `*character-replacements*'
320 and `*characters-to-drop*' for customization."
321 (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
323 (chars-to-replace (mapcar #'car *character-replacements*)))
324 (flet ((replacement-delimiter (index)
325 (cond ((or (< index 0) (>= index (length name))) "")
326 ((alphanumericp (char name index)) "-")
328 (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
331 do (setf name (concatenate 'string (subseq name 0 index)
332 (replacement-delimiter (1- index))
333 (cdr (assoc (aref name index)
334 *character-replacements*))
335 (replacement-delimiter (1+ index))
336 (subseq name (1+ index))))))
339 (defun unique-name (symbol package kind)
341 (format nil "~A-~A-~A"
343 (compiler-macro "compiler-macro")
345 ((macro-function symbol) "macro")
346 ((special-operator-p symbol) "special-operator")
348 (method-combination "method-combination")
350 (setf "setf-expander")
352 (type (let ((class (find-class symbol nil)))
354 (structure-class "struct")
355 (standard-class "class")
356 (sb-pcl::condition-class "condition")
357 ((or built-in-class null) "type"))))
358 (variable (if (constantp symbol)
361 (package-name package)
362 (alphanumize symbol))))
364 (defun def-begin (symbol kind)
366 (compiler-macro "@deffn {Compiler Macro}")
368 ((macro-function symbol) "@deffn Macro")
369 ((special-operator-p symbol) "@deffn {Special Operator}")
370 (t "@deffn Function")))
371 (method-combination "@deffn {Method Combination}")
372 (package "@defvr Package")
373 (setf "@deffn {Setf Expander}")
374 (structure "@deftp Structure")
375 (type (let ((class (find-class symbol nil)))
377 (structure-class "@deftp Structure")
378 (standard-class "@deftp Class")
379 (sb-pcl::condition-class "@deftp Condition")
380 ((or built-in-class null) "@deftp Type"))))
381 (variable (if (constantp symbol)
383 "@defvr Variable"))))
385 (defun def-index (symbol kind)
387 ((compiler-macro function method-combination)
388 (format nil "@findex ~A" (texinfoify symbol)))
390 (format nil "@tindex ~A" (texinfoify symbol)))
392 (format nil "@vindex ~A" (texinfoify symbol)))))
394 (defparameter *arglist-keywords*
395 '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
397 (defun texinfoify-arglist-part (part)
398 (with-output-to-string (s)
400 (string (prin1 (texinfoify part nil) s))
401 (number (prin1 part s))
403 (if (member part *arglist-keywords*)
404 (princ (texinfoify part) s)
405 (format s "@var{~A}" (texinfoify part))))
407 (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
409 (defun def-arglist (symbol kind)
412 (format nil "~{~A~^ ~}"
413 (mapcar #'texinfoify-arglist-part (argument-list symbol))))))
415 (defun def-end (symbol kind)
416 (declare (ignore symbol))
418 ((compiler-macro function method-combination setf) "@end deffn")
419 ((package variable) "@end defvr")
420 ((structure type) "@end deftp")))
422 (defun make-info-file (package &optional filename)
423 "Create a file containing all available documentation for the
424 exported symbols of `package' in Texinfo format. If `filename'
425 is not supplied, a file \"<packagename>.texinfo\" is generated.
427 The definitions can be referenced using Texinfo statements like
428 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
429 syntax-significant characters are escaped in symbol names, but
430 if a docstring contains invalid Texinfo markup, you lose."
431 (let* ((package (find-package package))
432 (filename (or filename (make-pathname
433 :name (string-downcase (package-name package))
435 (docs (sort (collect-documentation package) #'string< :key #'first)))
436 (with-open-file (out filename :direction :output
437 :if-does-not-exist :create :if-exists :supersede)
438 (loop for (symbol kind docstring) in docs
439 do (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
440 (unique-name symbol package kind)
441 (def-begin symbol kind)
442 (texinfoify (package-name package))
444 (def-arglist symbol kind)
445 (def-index symbol kind)
446 (frob-docstring docstring (argument-list symbol))
447 (def-end symbol kind))))
450 (defun docstrings-to-texinfo (directory &rest packages)
451 "Create files in `directory' containing Texinfo markup of all
452 docstrings of each exported symbol in `packages'. `directory'
453 is created if necessary. If you supply a namestring that
454 doesn't end in a slash, you lose. The generated files are of
455 the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
456 can be included via @include statements. Texinfo
457 syntax-significant characters are escaped in symbol names, but
458 if a docstring contains invalid Texinfo markup, you lose."
459 (let ((directory (merge-pathnames (pathname directory))))
460 (ensure-directories-exist directory)
461 (dolist (package packages)
463 with docs = (collect-documentation (find-package package))
464 for (symbol kind docstring) in docs
465 for doc-identifier = (unique-name symbol package kind)
466 do (with-open-file (out
468 (make-pathname :name doc-identifier :type "texinfo")
471 :if-does-not-exist :create :if-exists :supersede)
472 (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
473 (unique-name symbol package kind)
474 (def-begin symbol kind)
475 (texinfoify (package-name package))
477 (def-arglist symbol kind)
478 (def-index symbol kind)
479 (frob-docstring docstring (ignore-errors (argument-list symbol)))
480 (def-end symbol kind)))))