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
|
(in-package #:org.shirakumo.documentation-utils)
(defvar *documentation-tests* ())
(defun documentation-test (type)
(cdr (assoc type *documentation-tests*)))
(defun (setf documentation-test) (test type)
(if (assoc type *documentation-tests*)
(setf (cdr (assoc type *documentation-tests*)) test)
(push (cons type test) *documentation-tests*)))
(defun remove-documentation-test (type)
(setf *documentation-tests*
(remove type *documentation-tests* :key #'car)))
(defmacro define-documentation-test (type args &body body)
`(setf (documentation-test ',type)
(lambda ,args ,@body)))
(defvar *documentation-translators* ())
(defun documentation-translator (type)
(or (cdr (assoc type *documentation-translators*))
(lambda (form)
`(documentation ',(if (listp form) (first form) form) ',type))))
(defun (setf documentation-translator) (translator type)
(if (assoc type *documentation-translators*)
(setf (cdr (assoc type *documentation-translators*)) translator)
(push (cons type translator) *documentation-translators*)))
(defun remove-documentation-translator (type)
(setf *documentation-translators*
(remove type *documentation-translators* :key #'car)))
(defmacro define-documentation-translator (type args &body body)
`(setf (documentation-translator ',type)
(lambda ,args ,@body)))
(defmacro define-documentation-alias (alias type)
`(setf (documentation-translator ',alias)
(lambda (form) (funcall (documentation-translator ',type) form))))
(defun list-symbols (package &key (internal T))
(let ((symbs ())
(package (find-package package)))
(do-symbols (symb package (sort symbs #'string<))
(when (and (eql (symbol-package symb) package)
(or internal (eql :external (nth-value 1 (find-symbol (string symb) package)))))
(push symb symbs)))))
(defun check (&key (package *package*) (internal T))
(loop for (type . test) in (sort (copy-list *documentation-tests*)
#'string< :key #'car)
for reader = (documentation-translator type)
do (dolist (symb (list-symbols package :internal internal))
(when (and (funcall test symb) (not (handler-bind ((warning #'muffle-warning)) (documentation symb type))))
(warn "No documentation for ~(~a~) ~a." type symb)))))
(defclass documentation-formatter ()
())
(defgeneric format-documentation (formatter type var documentation))
(defclass plain-formatter (documentation-formatter)
())
(defmethod format-documentation ((formatter plain-formatter) type var documentation)
(check-type documentation string)
documentation)
(defun split-body-options (body)
(values (loop for list = body then rest
for (key val . rest) = list
while (and (cdr list) (keywordp key))
collect key collect val
finally (setf body list))
body))
(defun removef (plist &rest keys)
(loop for (key val) on plist by #'cddr
for test = (find key keys)
unless test collect key
unless test collect val))
(defvar *default-formatter* (make-instance 'plain-formatter))
(defmacro define-docs (&body expressions)
(multiple-value-bind (options expressions) (split-body-options expressions)
(let* ((formatter (or (getf options :formatter)
*default-formatter*))
(formatter (apply (etypecase formatter
(documentation-formatter #'reinitialize-instance)
(symbol #'make-instance))
formatter (removef options :formatter))))
`(progn
,@(loop for expr in expressions
for length = (length expr)
for type = (if (< 2 length) (first expr) 'function)
for var = (if (< 2 length) (rest (butlast expr)) (butlast expr))
for doc = (car (last expr))
collect `(setf ,(funcall (documentation-translator type) var)
,(format-documentation formatter type var doc)))))))
(trivial-indent:define-indentation define-docs (&rest (&whole 2 0 &body)))
(setf (documentation-test 'function) #'fboundp)
(setf (documentation-test 'variable) #'boundp)
(setf (documentation-test 'compiler-macro) #'compiler-macro-function)
(setf (documentation-test 'package) #'find-package)
(define-documentation-test type (symb)
(find-class symb NIL))
(define-documentation-translator method (expr)
(destructuring-bind (func &rest quals-specs) expr
(let* ((qualifiers (butlast quals-specs))
(specializers (car (last quals-specs)))
(clean-specs (loop for arg in specializers
until (find arg lambda-list-keywords)
collect (if (listp arg) (second arg) T))))
`(documentation (find-method #',func ',qualifiers ',(mapcar #'find-class clean-specs)) 't))))
(define-documentation-alias defun function)
(define-documentation-alias defmacro function)
(define-documentation-alias defgeneric function)
(define-documentation-alias defmethod method)
(define-documentation-alias defvar variable)
(define-documentation-alias defparameter variable)
(define-documentation-alias defconstant variable)
(define-documentation-alias defclass type)
(define-documentation-alias defstruct type)
(define-documentation-alias define-condition type)
(define-documentation-alias deftype type)
(define-documentation-alias define-method-combination method-combination)
(define-documentation-alias define-compiler-macro compiler-macro)
(define-documentation-alias defpackage package)
|
