3 ;;;; A docstring extractor for the sbcl manual. Creates
4 ;;;; @include-ready documentation from the docstrings of exported
5 ;;;; symbols of specified packages.
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.
11 ;;;; Written by Rudi Schlatte <rudi@constantly.at>
14 (eval-when (:compile-toplevel :load-toplevel :execute)
15 (require 'sb-introspect))
17 (defparameter *documentation-types*
22 ;;structure ; also handled by `type'
25 "A list of symbols accepted as second argument of `documentation'")
27 ;;; Collecting info from package
29 (defun documentation-for-symbol (symbol)
30 "Collects all doc for a symbol, returns a list of the
31 form (symbol doc-type docstring). See `*documentation-types*'
32 for the possible values of doc-type."
33 (loop for kind in *documentation-types*
34 for doc = (documentation symbol kind)
36 collect (list symbol kind doc)))
38 (defun collect-documentation (package)
39 "Collects all documentation for all external symbols of the
40 given package, as well as for the package itself."
41 (let* ((package (find-package package))
42 (package-doc (documentation package t))
44 (check-type package package)
45 (do-external-symbols (symbol package)
46 (let ((docs (documentation-for-symbol symbol)))
47 (when docs (setf result (nconc docs result)))))
49 (setf result (nconc (list (list (intern (package-name package) :keyword)
50 'package package-doc)) result)))
53 ;;; Helpers for texinfo output
55 (defvar *texinfo-escaped-chars* "@{}"
56 "Characters that must be escaped with #\@ for Texinfo.")
58 (defun texinfoify (string-designator &optional (downcase-p t))
59 "Return 'string-designator' with characters in
60 *texinfo-escaped-chars* escaped with #\@. Optionally downcase
62 (let ((result (with-output-to-string (s)
63 (loop for char across (string string-designator)
64 when (find char *texinfo-escaped-chars*)
66 do (write-char char s)))))
67 (if downcase-p (nstring-downcase result) result)))
69 (defvar *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ*:-+"
70 "List of characters that make up symbols in a docstring.")
72 (defvar *symbol-delimiters* " ,.!?")
74 (defun locate-symbols (line)
75 "Return a list of index pairs of symbol-like parts of LINE."
81 (when begin (push (list begin i) result))
84 ((and begin (find (char line i) *symbol-delimiters*))
85 ;; symbol end; remember it if it's not "A" or "I"
86 (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I))))
87 (push (list begin i) result))
90 ((and begin (not (find (char line i) *symbol-characters*)))
91 ;; Not a symbol: abort
93 ((and maybe-begin (not begin) (find (char line i) *symbol-characters*))
94 ;; potential symbol begin at this position
97 ((find (char line i) *symbol-delimiters*)
98 ;; potential symbol begin after this position
99 (setf maybe-begin t)))))
101 (defun all-symbols (list)
102 (cond ((or (null list) (numberp list)) nil)
103 ((atom list) (list list))
104 (t (append (all-symbols (car list)) (all-symbols (cdr list))))))
106 (defun frob-docstring (docstring symbol-arglist)
107 "Try to guess as much formatting for a raw docstring as possible."
108 ;; Per-line processing is not necessary now, but it will be when we
109 ;; attempt itemize / table auto-detection in docstrings
110 (with-output-to-string (result)
111 (let ((arglist-symbols (all-symbols symbol-arglist)))
112 (with-input-from-string (s (texinfoify docstring nil))
113 (loop for line = (read-line s nil nil)
116 (dolist (symbol-index (locate-symbols line))
117 (write-string (subseq line last (first symbol-index)) result)
118 (let ((symbol-name (apply #'subseq line symbol-index)))
119 (format result (if (member symbol-name arglist-symbols
123 (string-downcase symbol-name)))
124 (setf last (second symbol-index)))
125 (write-line (subseq line last) result)))))))
127 ;;; Begin, rest and end of definition.
129 (defun argument-list (fname)
130 (sb-introspect:function-arglist fname))
132 (defvar *character-replacements*
133 '((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
134 "Characters and their replacement names that `alphanumize'
135 uses. If the replacements contain any of the chars they're
136 supposed to replace, you deserve to lose.")
138 (defvar *characters-to-drop* '(#\\ #\` #\')
139 "Characters that should be removed by `alphanumize'.")
142 (defun alphanumize (symbol)
143 "Construct a string without characters like *`' that will
144 f-star-ck up filename handling. See `*character-replacements*'
145 and `*characters-to-drop*' for customization."
146 (let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
148 (chars-to-replace (mapcar #'car *character-replacements*)))
149 (flet ((replacement-delimiter (index)
150 (cond ((or (< index 0) (>= index (length name))) "")
151 ((alphanumericp (char name index)) "-")
153 (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
156 do (setf name (concatenate 'string (subseq name 0 index)
157 (replacement-delimiter (1- index))
158 (cdr (assoc (aref name index)
159 *character-replacements*))
160 (replacement-delimiter (1+ index))
161 (subseq name (1+ index))))))
164 (defun unique-name (symbol package kind)
166 (format nil "~A-~A-~A"
168 (compiler-macro "compiler-macro")
170 ((macro-function symbol) "macro")
171 ((special-operator-p symbol) "special-operator")
173 (method-combination "method-combination")
175 (setf "setf-expander")
177 (type (let ((class (find-class symbol nil)))
179 (structure-class "struct")
180 (standard-class "class")
181 (sb-pcl::condition-class "condition")
182 ((or built-in-class null) "type"))))
183 (variable (if (constantp symbol)
186 (package-name package)
187 (alphanumize symbol))))
189 (defun def-begin (symbol kind)
191 (compiler-macro "@deffn {Compiler Macro}")
193 ((macro-function symbol) "@deffn Macro")
194 ((special-operator-p symbol) "@deffn {Special Operator}")
195 (t "@deffn Function")))
196 (method-combination "@deffn {Method Combination}")
197 (package "@defvr Package")
198 (setf "@deffn {Setf Expander}")
199 (structure "@deftp Structure")
200 (type (let ((class (find-class symbol nil)))
202 (structure-class "@deftp Structure")
203 (standard-class "@deftp Class")
204 (sb-pcl::condition-class "@deftp Condition")
205 ((or built-in-class null) "@deftp Type"))))
206 (variable (if (constantp symbol)
208 "@defvr Variable"))))
210 (defun def-index (symbol kind)
212 ((compiler-macro function method-combination)
213 (format nil "@findex ~A" (texinfoify symbol)))
215 (format nil "@tindex ~A" (texinfoify symbol)))
217 (format nil "@vindex ~A" (texinfoify symbol)))))
219 (defparameter *arglist-keywords*
220 '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
222 (defun texinfoify-arglist-part (part)
223 (with-output-to-string (s)
225 (string (prin1 (texinfoify part nil) s))
226 (number (prin1 part s))
228 (if (member part *arglist-keywords*)
229 (princ (texinfoify part) s)
230 (format s "@var{~A}" (texinfoify part))))
232 (format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
234 (defun def-arglist (symbol kind)
237 (format nil "~{~A~^ ~}"
238 (mapcar #'texinfoify-arglist-part (argument-list symbol))))))
240 (defun def-end (symbol kind)
241 (declare (ignore symbol))
243 ((compiler-macro function method-combination setf) "@end deffn")
244 ((package variable) "@end defvr")
245 ((structure type) "@end deftp")))
247 (defun make-info-file (package &optional filename)
248 "Create a file containing all available documentation for the
249 exported symbols of `package' in Texinfo format. If `filename'
250 is not supplied, a file \"<packagename>.texinfo\" is generated.
252 The definitions can be referenced using Texinfo statements like
253 @ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
254 syntax-significant characters are escaped in symbol names, but
255 if a docstring contains invalid Texinfo markup, you lose."
256 (let* ((package (find-package package))
257 (filename (or filename (make-pathname
258 :name (string-downcase (package-name package))
260 (docs (sort (collect-documentation package) #'string< :key #'first)))
261 (with-open-file (out filename :direction :output
262 :if-does-not-exist :create :if-exists :supersede)
263 (loop for (symbol kind docstring) in docs
264 do (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
265 (unique-name symbol package kind)
266 (def-begin symbol kind)
267 (texinfoify (package-name package))
269 (def-arglist symbol kind)
270 (def-index symbol kind)
271 (frob-docstring docstring (argument-list symbol))
272 (def-end symbol kind))))
275 (defun docstrings-to-texinfo (directory &rest packages)
276 "Create files in `directory' containing Texinfo markup of all
277 docstrings of each exported symbol in `packages'. `directory'
278 is created if necessary. If you supply a namestring that
279 doesn't end in a slash, you lose. The generated files are of
280 the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
281 can be included via @include statements. Texinfo
282 syntax-significant characters are escaped in symbol names, but
283 if a docstring contains invalid Texinfo markup, you lose."
284 (let ((directory (merge-pathnames (pathname directory))))
285 (ensure-directories-exist directory)
286 (dolist (package packages)
288 with docs = (collect-documentation (find-package package))
289 for (symbol kind docstring) in docs
290 for doc-identifier = (unique-name symbol package kind)
291 do (with-open-file (out
293 (make-pathname :name doc-identifier :type "texinfo")
296 :if-does-not-exist :create :if-exists :supersede)
297 (format out "~&@anchor{~A}~%~A ~A:~A~@[ ~A~]~%~A~&~A~%~A~%~%"
298 (unique-name symbol package kind)
299 (def-begin symbol kind)
300 (texinfoify (package-name package))
302 (def-arglist symbol kind)
303 (def-index symbol kind)
304 (frob-docstring docstring (ignore-errors (argument-list symbol)))
305 (def-end symbol kind)))))