3 (defpackage :make-docstrings
7 (in-package :make-docstrings
)
9 (defclass formatting-stream
(trivial-gray-streams:fundamental-character-input-stream
)
10 ((understream :initarg
:understream
12 (width :initarg
:width
13 :initform
(error "missing :width argument to formatting-stream creation")
17 (word-wrap-p :initform t
18 :accessor word-wrap-p
)
19 (word-buffer :initform
(make-array 1000
20 :element-type
'character
23 :reader word-buffer
)))
25 (defun write-char%
(char stream
)
26 (incf (column stream
))
27 (write-char char
(understream stream
)))
29 (defun print-newline (stream)
30 (write-char #\Newline
(understream stream
))
31 (setf (column stream
) 0))
33 (defun buffer-not-empty-p (stream)
34 (plusp (length (word-buffer stream
))))
36 (defun maybe-flush-word (stream)
37 (when (buffer-not-empty-p stream
)
39 ((< (width stream
) (+ (column stream
) (length (word-buffer stream
))))
40 (print-newline stream
))
41 ((plusp (column stream
))
42 (write-char%
#\Space stream
)))
43 (loop for char across
(word-buffer stream
)
44 do
(write-char% char stream
))
45 (setf (fill-pointer (word-buffer stream
)) 0)))
47 (defmethod trivial-gray-streams:stream-write-char
((stream formatting-stream
) char
)
48 (if (word-wrap-p stream
)
51 (maybe-flush-word stream
))
53 (maybe-flush-word stream
)
54 (print-newline stream
))
56 (vector-push-extend char
(word-buffer stream
))))
57 (write-char char
(understream stream
))))
59 (defmethod trivial-gray-streams:stream-line-column
(stream)
60 (+ (column stream
) (length (word-buffer stream
))))
62 (defmethod trivial-gray-streams:stream-write-string
((stream formatting-stream
) string
&optional start end
)
63 (loop for i from
(or start
0) below
(or end
(length string
))
64 do
(write-char (char string i
) stream
)))
66 (defmethod trivial-gray-streams:stream-terpri
((stream formatting-stream
))
67 (write-char #\Newline stream
))
69 (defmethod close ((stream formatting-stream
) &key abort
)
71 (maybe-flush-word stream
)))
73 (defmethod (setf word-wrap-p
) :before
(new-value (stream formatting-stream
))
74 (maybe-flush-word stream
)
75 (when (buffer-not-empty-p stream
)
76 (print-newline stream
)))
78 (defun test-wrap-stream (text)
79 (with-output-to-string (s)
80 (with-open-stream (s (make-instance 'formatting-stream
:understream s
:width
20))
82 (setf (word-wrap-p s
) nil
)
86 (setf (word-wrap-p s
) t
)
87 (write-string text s
))))
89 (defmacro replace-regexp
(place regex replacement
)
90 `(setf ,place
(cl-ppcre:regex-replace-all
,regex
,place
,replacement
)))
92 (defun collapse-whitespace (string)
93 (replace-regexp string
"[ \\t]*\\n[ \\t]*" #.
(make-string 1 :initial-element
#\Newline
))
94 (replace-regexp string
"(?<!\\n)\\n" " ")
95 (remove #\Newline string
))
99 (defun xml-to-docstring%
(node transform
)
100 (stp:do-children
(child node
)
103 (write-string (funcall transform
(stp:data child
)) *output
*))
105 (ecase (intern (string-upcase (stp:local-name child
)) :keyword
)
109 (xml-to-docstring% child transform
))
110 ((:a
:code
:tt
:blockquote
:span
:ul
)
111 (xml-to-docstring% child transform
))
113 (xml-to-docstring% child transform
)
116 (xml-to-docstring% child
(alexandria:compose
#'string-upcase transform
)))
123 (setf (word-wrap-p *output
*) nil
)
124 (xml-to-docstring% child
#'identity
)
125 (setf (word-wrap-p *output
*) t
)
126 (terpri *output
*)))))))
128 (defun xml-to-docstring (description-node)
129 (with-output-to-string (s)
130 (with-open-stream (*output
* (make-instance 'formatting-stream
:understream s
:width
75))
131 (xml-to-docstring% description-node
#'collapse-whitespace
))))
133 (defun maybe-qualify-name (name package-name
)
136 (format nil
"~A:~A" package-name name
)))
138 (defun get-doc-entry-type (node)
139 (let ((basic-type (intern (string-upcase (stp:local-name node
)) :keyword
)))
140 (if (eq basic-type
:function
)
141 (if (stp:attribute-value node
"generic") ; FIXME: "no" not recognized
146 (defun skip-to (stream char
)
147 (loop until
(eql char
(peek-char nil stream
))
148 do
(read-char stream
)))
150 (defun get-simple-def-docstring (source-string position
)
151 (with-input-from-string (s source-string
:start
(1+ position
))
152 (read s
) ; DEFUN/DEFVAR/DEFPARAMETER
154 (read s
) ; argument list/initial value
156 (list :start
(file-position s
)
158 :end
(file-position s
))))
160 (defun get-complex-def-docstring (source-string position
)
161 (with-input-from-string (s source-string
:start
(1+ position
))
162 (read s
) ; DEFCLASS/DEFINE-CONDITION/DEFGENERIC
164 (read s
) ; arguments/supers
166 (let* ((start-of-clause (file-position s
))
168 (when (eql (first clause
) :documentation
)
169 (file-position s start-of-clause
)
172 (read s
) ; :DOCUMENTATION
174 (return (list :start
(file-position s
)
176 :end
(file-position s
))))))))
178 (defun get-doc-function (type)
180 ((:function
:special-variable
) 'get-simple-def-docstring
)
181 ((:generic-function
:class
) 'get-complex-def-docstring
)))
183 (defun source-location-flatten (location-info)
184 (apply #'append
(rest (find :location
(rest location-info
) :key
#'first
))))
189 ((file-pathname :initarg
:file-pathname
190 :reader file-pathname
)
191 (docstrings :initform nil
192 :accessor docstrings
)
193 (contents :accessor contents
)))
195 (defmethod initialize-instance :after
((file file
) &key file-pathname
)
196 (setf (slot-value file
'contents
) (alexandria:read-file-into-string file-pathname
)))
198 (defun get-file (pathname)
199 (or (gethash pathname
*files
*)
200 (setf (gethash pathname
*files
*)
202 :file-pathname pathname
))))
204 (defun record-docstring (doc-docstring get-doc-function symbol-name
)
205 (let ((definitions (remove-if (lambda (definition)
206 (or (cl-ppcre:scan
"(?i)^\\s*\\(defmethod\\s" (first definition
))
207 (eql (first (second definition
)) :error
)))
208 (swank:find-definitions-for-emacs symbol-name
))))
209 (case (length definitions
)
210 (0 (warn "no source location for ~A" symbol-name
))
211 (1 (let* ((source-location (source-location-flatten (first definitions
)))
212 (file (get-file (getf source-location
:file
))))
213 (push (list* :doc-docstring doc-docstring
214 (funcall get-doc-function
(contents file
) (getf source-location
:position
)))
216 (2 (warn "multiple source locations for ~A" symbol-name
)))))
218 (defun parse-doc (pathname default-package-name
)
219 (let ((*files
* (make-hash-table :test
#'equal
)))
220 (xpath:with-namespaces
(("clix" "http://bknr.net/clixdoc"))
221 (xpath:do-node-set
(node (xpath:evaluate
"//*[clix:description!='']" (cxml:parse pathname
(stp:make-builder
))))
222 (let ((type (get-doc-entry-type node
))
223 (symbol-name (maybe-qualify-name (stp:attribute-value node
"name") default-package-name
)))
224 (xpath:do-node-set
(description (xpath:evaluate
"clix:description" node
))
225 (alexandria:when-let
(get-doc-function (get-doc-function type
))
226 (record-docstring (xml-to-docstring description
)
227 get-doc-function symbol-name
))))))