sod/doc.sty: Reorganize and improve documentation.
[sod] / doc / list-exports.lisp
1 #! /bin/sh
2 ":"; ### -*-lisp-*-
3 ":"; CL_SOURCE_REGISTRY=$(pwd)/build/src/:; export CL_SOURCE_REGISTRY
4 ":"; exec cl-launch -X -l "sbcl cmucl" -s asdf -i "(sod-exports::main)" -- "$0" "$@" || exit 1
5
6 (cl:defpackage #:sod-exports
7 (:use #:common-lisp
8 #+cmu #:mop
9 #+sbcl #:sb-mop))
10
11 (cl:in-package #:sod-exports)
12 (eval-when (:compile-toplevel :load-toplevel :execute)
13 (mapc #'asdf:load-system '(:sod :sod-frontend)))
14
15 (defun symbolicate (&rest things)
16 (intern (apply #'concatenate 'string (mapcar #'string things))))
17
18 (defun incomprehensible-form (head tail)
19 (format *error-output* ";; incomprehensible: ~S~%" (cons head tail)))
20
21 (defgeneric form-list-exports (head tail)
22 (:method (head tail)
23 (declare (ignore head tail))
24 nil))
25
26 (defmethod form-list-exports ((head (eql 'cl:export)) tail)
27 (let ((symbols (car tail)))
28 (if (and (consp symbols)
29 (eq (car symbols) 'quote))
30 (let ((thing (cadr symbols)))
31 (if (atom thing) (list thing) thing))
32 (incomprehensible-form head tail))))
33
34 (defmethod form-list-exports ((head (eql 'sod:definst)) tail)
35 (destructuring-bind (code (streamvar &key export) args &body body) tail
36 (declare (ignore streamvar body))
37 (and export
38 (list* (symbolicate code '-inst)
39 (symbolicate 'make- code '-inst)
40 (labels ((dig (tree path)
41 (if (or (atom tree) (null path)) tree
42 (dig (nth (car path) tree) (cdr path))))
43 (cook (arg)
44 (if (consp arg) (car arg)
45 (let ((name (symbol-name arg)))
46 (if (char= (char name 0) #\%)
47 (intern (subseq name 1))
48 arg))))
49 (instify (arg)
50 (symbolicate 'inst- (cook arg))))
51 (loop with state = :mandatory
52 for arg in args
53 if (and (symbolp arg)
54 (char= (char (symbol-name arg) 0) #\&))
55 do (setf state arg)
56 else if (member state '(:mandatory &rest))
57 collect (instify arg)
58 else if (member state '(&optional &aux))
59 collect (instify (dig arg '(0)))
60 else if (eq state '&key)
61 collect (instify (dig arg '(0 1)))
62 else
63 do (error "Confused by ~S." arg)))))))
64
65 (defmethod form-list-exports ((head (eql 'sod::define-tagged-type)) tail)
66 (destructuring-bind (kind what) tail
67 (declare (ignore what))
68 (list kind
69 (symbolicate 'c- kind '-type)
70 (symbolicate 'make- kind '-type))))
71
72 (defmethod form-list-exports ((head (eql 'sod:defctype)) tail)
73 (destructuring-bind (names value &key export) tail
74 (declare (ignore value))
75 (let ((names (if (listp names) names (list names))))
76 (and export
77 (list* (symbolicate 'c-type- (car names)) names)))))
78
79 (defmethod form-list-exports ((head (eql 'sod:define-simple-c-type)) tail)
80 (destructuring-bind (names type &key export) tail
81 (declare (ignore type))
82 (let ((names (if (listp names) names (list names))))
83 (and export
84 (list* (symbolicate 'c-type- (car names)) names)))))
85
86 (defmethod form-list-exports ((head (eql 'cl:macrolet)) tail)
87 (mapcan #'form-exports (cdr tail)))
88
89 (defmethod form-list-exports ((head (eql 'cl:eval-when)) tail)
90 (mapcan #'form-exports (cdr tail)))
91
92 (defmethod form-list-exports ((head (eql 'cl:progn)) tail)
93 (mapcan #'form-exports tail))
94
95 (defgeneric form-exports (form)
96 (:method (form) nil)
97 (:method ((form cons)) (form-list-exports (car form) (cdr form))))
98
99 (defgeneric list-exports (thing))
100
101 (defmethod list-exports ((stream stream))
102 (loop with eof = '#:eof
103 for form = (read stream nil eof)
104 until (eq form eof)
105 when (consp form) nconc (form-exports form)))
106
107 (defmethod list-exports ((path pathname))
108 (mapcar (lambda (each)
109 (cons each (with-open-file (stream each) (list-exports stream))))
110 (directory (merge-pathnames path #p"*.lisp"))))
111
112 (defmethod list-exports ((path string))
113 (list-exports (pathname path)))
114
115 (defun list-exported-symbols (package)
116 (sort (loop for s being the external-symbols of package collect s)
117 #'string< :key #'symbol-name))
118
119 (defun find-symbol-homes (paths package)
120 (let* ((symbols (list-exported-symbols package))
121 (exports-alist (let ((*package* package))
122 (mapcan #'list-exports paths)))
123 (homes (make-hash-table :test #'equal)))
124 (dolist (assoc exports-alist)
125 (let ((home (car assoc)))
126 (dolist (symbol (cdr assoc))
127 (let ((name (symbol-name symbol)))
128 (unless (nth-value 1 (find-symbol name package))
129 (format *error-output* ";; unexported: ~S~%" symbol))
130 (setf (gethash name homes) home)))))
131 (dolist (symbol symbols)
132 (unless (gethash (symbol-name symbol) homes)
133 (format *error-output* ";; mysterious: ~S~%" symbol)))
134 exports-alist))
135
136 (defun boring-setf-expansion-p (symbol)
137 (multiple-value-bind (temps args stores store fetch)
138 (ignore-errors (get-setf-expansion (list symbol)))
139 (declare (ignore temps args stores fetch))
140 (and (consp store)
141 (eq (car store) 'funcall)
142 (consp (cdr store)) (consp (cadr store))
143 (eq (caadr store) 'function)
144 (let ((func (cadadr store)))
145 (and (consp func) (consp (cdr func))
146 (eq (car func) 'setf))))))
147
148 (defun specialized-on-p (func arg what)
149 (some (lambda (method)
150 (let ((spec (nth arg (method-specializers method))))
151 (and (typep spec 'eql-specializer)
152 (eql (eql-specializer-object spec) what))))
153 (generic-function-methods func)))
154
155 (defun categorize (symbol)
156 (let ((things nil))
157 (when (boundp symbol)
158 (push (if (constantp symbol) :constant :variable) things))
159 (when (fboundp symbol)
160 (push (cond ((macro-function symbol) :macro)
161 ((typep (fdefinition symbol) 'generic-function)
162 :generic)
163 (t :function))
164 things)
165 (when (or ;;(not (boring-setf-expansion-p symbol))
166 (ignore-errors (fdefinition (list 'setf symbol))))
167 (push :setf things)))
168 (when (find-class symbol nil)
169 (push :class things))
170 (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol)
171 (specialized-on-p #'sod:expand-c-type-form 0 symbol))
172 (push :c-type things))
173 (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol)
174 (specialized-on-p #'sod-parser:expand-parser-form 1 symbol))
175 (push :parser things))
176 (when (get symbol 'optparse::opthandler)
177 (push :opthandler things))
178 (when (get symbol 'optparse::optmacro)
179 (push :optmacro things))
180 (nreverse things)))
181
182 (defun categorize-symbols (paths package)
183 (mapcar (lambda (assoc)
184 (let ((home (car assoc))
185 (symbols (delete-duplicates
186 (sort (mapcan (lambda (sym)
187 (multiple-value-bind
188 (symbol foundp)
189 (find-symbol
190 (symbol-name sym)
191 package)
192 (and foundp (list symbol))))
193 (cdr assoc))
194 #'string< :key #'symbol-name))))
195 (cons home (mapcar (lambda (symbol)
196 (cons symbol (categorize symbol)))
197 symbols))))
198
199 (find-symbol-homes paths package)))
200
201 (defun best-package-name (package)
202 (car (sort (cons (package-name package)
203 (copy-list (package-nicknames package)))
204 #'< :key #'length)))
205
206 (defvar charbuf-size 0)
207
208 (defun exported-symbol-p (symbol &optional (package (symbol-package symbol)))
209 (and package
210 (multiple-value-bind (sym how)
211 (find-symbol (symbol-name symbol) package)
212 (and (eq sym symbol)
213 (eq how :external)))))
214
215 (defun pretty-symbol-name (symbol package)
216 (let ((pkg (symbol-package symbol))
217 (exportp (exported-symbol-p symbol)))
218 (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)"
219 (and exportp (eq pkg package))
220 (cond ((keywordp symbol) "")
221 ((eq pkg nil) "#")
222 (t (best-package-name pkg)))
223 (or exportp (null pkg)) (symbol-name symbol))))
224
225 (deftype interesting-class ()
226 '(or standard-class
227 structure-class
228 #.(class-name (class-of (find-class 'condition)))))
229
230 (defun analyse-classes (package)
231 (setf package (find-package package))
232 (let ((classes (mapcan (lambda (symbol)
233 (let ((class (find-class symbol nil)))
234 (and class
235 (typep class 'interesting-class)
236 (list class))))
237 (list-exported-symbols package)))
238 (subs (make-hash-table)))
239 (let ((done (make-hash-table)))
240 (labels ((walk-up (class)
241 (unless (gethash class done)
242 (dolist (super (class-direct-superclasses class))
243 (push class (gethash super subs))
244 (walk-up super))
245 (setf (gethash class done) t))))
246 (dolist (class classes)
247 (walk-up class))))
248 (labels ((walk-down (this super depth)
249 (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%"
250 (* 2 depth)
251 (pretty-symbol-name (class-name this) package)
252 (mapcar (lambda (class)
253 (pretty-symbol-name (class-name class)
254 package))
255 (remove super
256 (class-direct-superclasses this))))
257 (dolist (sub (sort (copy-list (gethash this subs))
258 #'string< :key #'class-name))
259 (walk-down sub this (1+ depth)))))
260 (walk-down (find-class t) nil 0))))
261
262 (defmacro deep-compare ((left right) &body body)
263 (let ((block (gensym "BLOCK-")) (func (gensym "FUNC-"))
264 (l (gensym "LEFT-")) (r (gensym "RIGHT-")))
265 `(macrolet ((focus (expr &body body)
266 `(flet ((,',func (it) ,expr))
267 (let ((,',l (,',func ,',l))
268 (,',r (,',func ,',r)))
269 ,@body)))
270 (update (expr)
271 `(flet ((,',func (it) ,expr))
272 (psetf ,',l (,',func ,',l)
273 ,',r (,',func ,',r))))
274 (compare (expr)
275 `(cond ((let ((left ,',l) (right ,',r)) ,expr)
276 (return-from ,',block t))
277 ((let ((right ,',l) (left ,',r)) ,expr)
278 (return-from ,',block nil))))
279 (typesw (&rest clauses)
280 (labels ((iter (clauses)
281 (if (null clauses)
282 'nil
283 (destructuring-bind (type &rest body)
284 (car clauses)
285 (if (eq type t)
286 `(progn ,@body)
287 `(if (typep ,',l ',type)
288 (if (typep ,',r ',type)
289 (progn ,@body)
290 (return-from ,',block t))
291 (if (typep ,',r ',type)
292 (return-from ,',block nil)
293 ,(iter (cdr clauses)))))))))
294 (iter clauses))))
295 (let ((,l ,left) (,r ,right))
296 (block ,block
297 ,@body)))))
298
299 (defun order-specializers (la lb)
300 (deep-compare (la lb)
301 (loop (typesw (null (return nil)))
302 (focus (car it)
303 (typesw (eql-specializer
304 (focus (eql-specializer-object it)
305 (typesw (keyword
306 (compare (string< left right)))
307 (symbol
308 (focus (package-name (symbol-package it))
309 (compare (string< left right)))
310 (compare (string< left right)))
311 (t
312 (focus (with-output-to-string (out)
313 (prin1 it out)
314 (write-char #\nul))
315 (compare (string< left right)))))))
316 (class
317 (focus (class-name it)
318 (focus (package-name (symbol-package it))
319 (compare (string< left right)))
320 (compare (string< left right))))
321 (t
322 (error "unexpected things"))))
323 (update (cdr it)))))
324
325 (defun analyse-generic-functions (package)
326 (setf package (find-package package))
327 (flet ((function-name-core (name)
328 (typecase name
329 (symbol (values name t))
330 ((cons (eql setf) t) (values (cadr name) t))
331 (t (values nil nil)))))
332 (let ((methods (make-hash-table))
333 (functions (make-hash-table))
334 (externs (make-hash-table)))
335 (dolist (symbol (list-exported-symbols package))
336 (setf (gethash symbol externs) t))
337 (dolist (symbol (list-exported-symbols package))
338 (flet ((dofunc (func)
339 (when (typep func 'generic-function)
340 (setf (gethash func functions) t)
341 (dolist (method (generic-function-methods func))
342 (setf (gethash method methods) t)))))
343 (dofunc (and (fboundp symbol) (fdefinition symbol)))
344 (dofunc (ignore-errors (fdefinition (list 'setf symbol)))))
345 (when (eq (symbol-package symbol) package)
346 (let ((class (find-class symbol nil)))
347 (when class
348 (dolist
349 (func (specializer-direct-generic-functions class))
350 (multiple-value-bind (name knownp)
351 (function-name-core (generic-function-name func))
352 (when (and knownp
353 (or (not (eq (symbol-package name) package))
354 (gethash name externs)))
355 (setf (gethash func functions) t)
356 (dolist (method (specializer-direct-methods class))
357 (setf (gethash method methods) t)))))))))
358 (let ((funclist nil))
359 (maphash (lambda (func value)
360 (declare (ignore value))
361 (push func funclist))
362 functions)
363 (setf funclist (sort funclist
364 (lambda (a b)
365 (let ((core-a (function-name-core a))
366 (core-b (function-name-core b)))
367 (if (eq core-a core-b)
368 (and (atom a) (consp b))
369 (string< core-a core-b))))
370 :key #'generic-function-name))
371 (dolist (function funclist)
372 (let ((name (generic-function-name function)))
373 (etypecase name
374 (symbol
375 (format t "~A~%" (pretty-symbol-name name package)))
376 ((cons (eql setf) t)
377 (format t "(setf ~A)~%"
378 (pretty-symbol-name (cadr name) package)))))
379 (dolist (method (sort (copy-list
380 (generic-function-methods function))
381 #'order-specializers
382 :key #'method-specializers))
383 (when (gethash method methods)
384 (format t "~2T~{~A~^ ~}~@[ [~{~(~S~)~^ ~}]~]~%"
385 (mapcar
386 (lambda (spec)
387 (etypecase spec
388 (class
389 (let ((name (class-name spec)))
390 (if (eq name t) "t"
391 (pretty-symbol-name name package))))
392 (eql-specializer
393 (let ((obj (eql-specializer-object spec)))
394 (format nil "(eql ~A)"
395 (if (symbolp obj)
396 (pretty-symbol-name obj package)
397 obj))))))
398 (method-specializers method))
399 (method-qualifiers method)))))))))
400
401 (defun check-slot-names (package)
402 (setf package (find-package package))
403 (let* ((symbols (list-exported-symbols package))
404 (classes (mapcan (lambda (symbol)
405 (when (eq (symbol-package symbol) package)
406 (let ((class (find-class symbol nil)))
407 (and class (list class)))))
408 symbols))
409 (offenders (mapcan
410 (lambda (class)
411 (let* ((slot-names
412 (mapcar #'slot-definition-name
413 (class-direct-slots class)))
414 (exported (remove-if
415 (lambda (sym)
416 (or (not (symbol-package sym))
417 (and (not (exported-symbol-p
418 sym))
419 (eq (symbol-package sym)
420 package))))
421 slot-names)))
422 (and exported
423 (list (cons (class-name class)
424 exported)))))
425 classes))
426 (bad-words (remove-duplicates (mapcan (lambda (list)
427 (copy-list (cdr list)))
428 offenders))))
429 (values offenders bad-words)))
430
431 (defun report-symbols (paths package)
432 (setf package (find-package package))
433 (format t "~A~%Package `~(~A~)'~2%"
434 (make-string 77 :initial-element #\-)
435 (package-name package))
436 (dolist (assoc (sort (categorize-symbols paths package) #'string<
437 :key (lambda (assoc)
438 (file-namestring (car assoc)))))
439 (when (cdr assoc)
440 (format t "~A~%" (file-namestring (car assoc)))
441 (dolist (def (cdr assoc))
442 (let ((sym (car def)))
443 (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%"
444 (pretty-symbol-name sym package)
445 (cdr def))))
446 (terpri)))
447 (multiple-value-bind (alist names) (check-slot-names package)
448 (when names
449 (format t "Leaked slot names: ~{~A~^, ~}~%"
450 (mapcar (lambda (name) (pretty-symbol-name name package))
451 names))
452 (dolist (assoc alist)
453 (format t "~2T~A: ~{~A~^, ~}~%"
454 (pretty-symbol-name (car assoc) package)
455 (mapcar (lambda (name) (pretty-symbol-name name package))
456 (cdr assoc))))
457 (terpri)))
458 (format t "Classes:~%")
459 (analyse-classes package)
460 (terpri)
461 (format t "Methods:~%")
462 (analyse-generic-functions package)
463 (terpri))
464
465 (export 'report-project-symbols)
466 (defun report-project-symbols ()
467 (labels ((components (comp)
468 (asdf:component-children comp))
469 (files (comp)
470 (sort (remove-if-not (lambda (comp)
471 (typep comp 'asdf:cl-source-file))
472 (components comp))
473 #'string< :key #'asdf:component-name))
474 (by-name (comp name)
475 (gethash name (asdf:component-children-by-name comp)))
476 (file-name (file)
477 (slot-value file 'asdf/component:absolute-pathname)))
478 (let* ((sod (asdf:find-system "sod"))
479 (parser-files (files (by-name sod "parser")))
480 (utilities (by-name sod "utilities"))
481 (sod-frontend (asdf:find-system "sod-frontend"))
482 (optparse (by-name sod "optparse"))
483 (frontend (by-name sod-frontend "frontend"))
484 (sod-files (set-difference (files sod) (list optparse utilities))))
485 (report-symbols (mapcar #'file-name sod-files) "SOD")
486 (report-symbols (mapcar #'file-name (list frontend)) "SOD-FRONTEND")
487 (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER")
488 (report-symbols (mapcar #'file-name (list optparse)) "OPTPARSE")
489 (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES"))))
490
491 (defun main ()
492 (with-open-file (*standard-output* #p"doc/SYMBOLS"
493 :direction :output
494 :if-exists :supersede
495 :if-does-not-exist :create)
496 (report-project-symbols)))
497
498 #+interactive (main)