[3d19a6]: doc / manual / docstrings.lisp Maximize Restore History

Download this file

docstrings.lisp    237 lines (212 with data), 9.2 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
;;;; -*- lisp -*-
;;;; (c) 2004 Rudi Schlatte <rudi@constantly.at>
;;;; Use it as you wish, send changes back to me if you like.
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-introspect))
(defparameter *documentation-types*
'(compiler-macro
function
method-combination
setf
;;structure ; also handled by `type'
type
variable)
"A list of symbols accepted as second argument of `documentation'")
;;; Collecting info from package
(defun documentation-for-symbol (symbol)
"Collects all doc for a symbol, returns a list of the
form (symbol doc-type docstring). See `*documentation-types*'
for the possible values of doc-type."
(loop for kind in *documentation-types*
for doc = (documentation symbol kind)
when doc
collect (list symbol kind doc)))
(defun collect-documentation (package)
"Collects all documentation for all external symbols of the
given package, as well as for the package itself."
(let* ((package (find-package package))
(package-doc (documentation package t))
(result nil))
(check-type package package)
(do-external-symbols (symbol package)
(let ((docs (documentation-for-symbol symbol)))
(when docs (setf result (nconc docs result)))))
(when package-doc
(setf result (nconc (list (list (intern (package-name package) :keyword)
'package package-doc)) result)))
result))
;;; Helpers for texinfo output
(defvar *texinfo-escaped-chars* "@{}"
"Characters that must be escaped with #\@ for Texinfo.")
(defun texinfoify (string-designator)
"Return 'string-designator' with characters in
*texinfo-escaped-chars* escaped with #\@"
(let ((name (string string-designator)))
(nstring-downcase
(with-output-to-string (s)
(loop for char across name
when (find char *texinfo-escaped-chars*)
do (write-char #\@ s)
do (write-char char s))))))
;;; Begin, rest and end of definition.
(defun argument-list (fname)
(sb-introspect:function-arglist fname))
(defvar *character-replacements*
'((#\* . "star") (#\/ . "slash") (#\+ . "plus"))
"Characters and their replacement names that `alphanumize'
uses. If the replacements contain any of the chars they're
supposed to replace, you deserve to lose.")
(defvar *characters-to-drop* '(#\\ #\` #\')
"Characters that should be removed by `alphanumize'.")
(defun alphanumize (symbol)
"Construct a string without characters like *`' that will
f-star-ck up filename handling. See `*character-replacements*'
and `*characters-to-drop*' for customization."
(let ((name (remove-if #'(lambda (x) (member x *characters-to-drop*))
(string symbol)))
(chars-to-replace (mapcar #'car *character-replacements*)))
(flet ((replacement-delimiter (index)
(cond ((or (< index 0) (>= index (length name))) "")
((alphanumericp (char name index)) "-")
(t ""))))
(loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
name)
while index
do (setf name (concatenate 'string (subseq name 0 index)
(replacement-delimiter (1- index))
(cdr (assoc (aref name index)
*character-replacements*))
(replacement-delimiter (1+ index))
(subseq name (1+ index))))))
name))
(defun unique-name (symbol package kind)
(nstring-downcase
(format nil "~A-~A-~A"
(ecase kind
(compiler-macro "compiler-macro")
(function (cond
((macro-function symbol) "macro")
((special-operator-p symbol) "special-operator")
(t "fun")))
(method-combination "method-combination")
(package "package")
(setf "setf-expander")
(structure "struct")
(type (let ((class (find-class symbol)))
(etypecase class
(structure-class "struct")
(standard-class "class")
(sb-pcl::condition-class "condition")
((or built-in-class null) "type"))))
(variable (if (constantp symbol)
"constant"
"var")))
(package-name package)
(alphanumize symbol))))
(defun def-begin (symbol kind)
(ecase kind
(compiler-macro "@deffn {Compiler Macro}")
(function (cond
((macro-function symbol) "@defmac")
((special-operator-p symbol) "@defspec")
(t "@defun")))
(method-combination "@deffn {Method Combination}")
(package "@deffn Package")
(setf "@deffn {Setf Expander}")
(structure "@deftp Structure")
(type (let ((class (find-class symbol)))
(etypecase class
(structure-class "@deftp Structure")
(standard-class "@deftp Class")
(sb-pcl::condition-class "@deftp Condition")
((or built-in-class null) "@deftp Type"))))
(variable (if (constantp symbol)
"@defvr Constant"
"@defvar"))))
(defparameter *arglist-keywords*
'(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
(defun texinfoify-arglist-part (part)
(with-output-to-string (s)
(etypecase part
(string (prin1 (texinfoify part) s))
(number (prin1 part s))
(symbol
(if (member part *arglist-keywords*)
(princ (texinfoify part) s)
(format s "@var{~A}" (texinfoify part))))
(list
(format s "(~{~A~^ ~})" (mapcar #'texinfoify-arglist-part part))))))
(defun def-rest (symbol kind)
(case kind
(function
(format nil "~{~A~^ ~}" (mapcar #'texinfoify-arglist-part
(argument-list symbol))))))
(defun def-end (symbol kind)
(ecase kind
(compiler-macro "@end deffn")
(function (cond
((macro-function symbol) "@end defmac")
((special-operator-p symbol) "@end defspec")
(t "@end defun")))
(method-combination "@end deffn")
(package "@end deffn")
(setf "@end deffn")
(type "@end deftp")
(variable (if (constantp symbol)
"@end defvr"
"@defvar"))))
(defun make-info-file (package &optional filename)
"Create a file containing all available documentation for the
exported symbols of `package' in Texinfo format. If `filename'
is not supplied, a file \"<packagename>.texinfo\" is generated.
The definitions can be referenced using Texinfo statements like
@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo
syntax-significant characters are escaped in symbol names, but
if a docstring contains invalid Texinfo markup, you lose."
(let* ((package (find-package package))
(filename (or filename (make-pathname
:name (string-downcase (package-name package))
:type "texinfo")))
(docs (sort (collect-documentation package) #'string< :key #'first)))
(with-open-file (out filename :direction :output
:if-does-not-exist :create :if-exists :supersede)
(loop for (symbol kind docstring) in docs
do (format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
(unique-name symbol package kind)
(def-begin symbol kind)
(texinfoify symbol)
(def-rest symbol kind)
docstring
(def-end symbol kind))))
filename))
(defun docstrings-to-texinfo (directory &rest packages)
"Create files in `directory' containing Texinfo markup of all
docstrings of each exported symbol in `packages'. `directory'
is created if necessary. If you supply a namestring that
doesn't end in a slash, you lose. The generated files are of
the form \"<doc-type>_<packagename>_<symbol-name>.texinfo\" and
can be included via @include statements. Texinfo
syntax-significant characters are escaped in symbol names, but
if a docstring contains invalid Texinfo markup, you lose."
(let ((directory (merge-pathnames (pathname directory))))
(ensure-directories-exist directory)
(dolist (package packages)
(loop
with docs = (collect-documentation (find-package package))
for (symbol kind docstring) in docs
for doc-identifier = (unique-name symbol package kind)
do (with-open-file (out
(merge-pathnames
(make-pathname :name doc-identifier :type "texinfo")
directory)
:direction :output
:if-does-not-exist :create :if-exists :supersede)
(format out "~&@anchor{~A}~%~A ~A~@[ ~A~]~%~A~%~A~%~%"
(unique-name symbol package kind)
(def-begin symbol kind)
(texinfoify symbol)
(def-rest symbol kind)
docstring
(def-end symbol kind)))))
directory))