make-docstrings.lisp 1 ;; -*- Lisp -*-
2
3 (defpackage :make-docstrings
4 (:use :cl)
5 (:export #:parse-doc))
6
7 (in-package :make-docstrings)
8
9 (defclass formatting-stream (trivial-gray-streams:fundamental-character-input-stream)
10 ((understream :initarg :understream
11 :reader understream)
12 (width :initarg :width
13 :initform (error "missing :width argument to formatting-stream creation")
14 :reader width)
15 (column :initform 0
16 :accessor column)
17 (word-wrap-p :initform t
18 :accessor word-wrap-p)
19 (word-buffer :initform (make-array 1000
20 :element-type 'character
21 :adjustable t
22 :fill-pointer 0)
23 :reader word-buffer)))
24
25 (defun write-char% (char stream)
26 (incf (column stream))
27 (write-char char (understream stream)))
28
29 (defun print-newline (stream)
30 (write-char #\Newline (understream stream))
31 (setf (column stream) 0))
32
33 (defun buffer-not-empty-p (stream)
34 (plusp (length (word-buffer stream))))
35
36 (defun maybe-flush-word (stream)
37 (when (buffer-not-empty-p stream)
38 (cond
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)))
46
47 (defmethod trivial-gray-streams:stream-write-char ((stream formatting-stream) char)
48 (if (word-wrap-p stream)
49 (cond
50 ((eql #\Space char)
51 (maybe-flush-word stream))
52 ((eql #\Newline char)
53 (maybe-flush-word stream)
54 (print-newline stream))
55 (t
56 (vector-push-extend char (word-buffer stream))))
57 (write-char char (understream stream))))
58
59 (defmethod trivial-gray-streams:stream-line-column (stream)
60 (+ (column stream) (length (word-buffer stream))))
61
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)))
65
66 (defmethod trivial-gray-streams:stream-terpri ((stream formatting-stream))
67 (write-char #\Newline stream))
68
69 (defmethod close ((stream formatting-stream) &key abort)
70 (unless abort
71 (maybe-flush-word stream)))
72
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)))
77
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))
81 (write-string text s)
82 (setf (word-wrap-p s) nil)
83 (format s "~&OFF~%")
84 (write-string text s)
85 (format s "~&ON~%")
86 (setf (word-wrap-p s) t)
87 (write-string text s))))
88
89 (defmacro replace-regexp (place regex replacement)
90 `(setf ,place (cl-ppcre:regex-replace-all ,regex ,place ,replacement)))
91
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))
96
97 (defvar *output*)
98
99 (defun xml-to-docstring% (node transform)
100 (stp:do-children (child node)
101 (typecase child
102 (stp:text
103 (write-string (funcall transform (stp:data child)) *output*))
104 (stp:element
105 (ecase (intern (string-upcase (stp:local-name child)) :keyword)
106 (:p
107 (terpri *output*)
108 (terpri *output*)
109 (xml-to-docstring% child transform))
110 ((:a :code :tt :blockquote :span :ul)
111 (xml-to-docstring% child transform))
112 ((:li)
113 (xml-to-docstring% child transform)
114 (terpri *output*))
115 ((:ref :arg :em :i)
116 (xml-to-docstring% child (alexandria:compose #'string-upcase transform)))
117 ((:sup)
118 ;; skip
119 )
120 (:pre
121 (terpri *output*)
122 (terpri *output*)
123 (setf (word-wrap-p *output*) nil)
124 (xml-to-docstring% child #'identity)
125 (setf (word-wrap-p *output*) t)
126 (terpri *output*)))))))
127
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))))
132
133 (defun maybe-qualify-name (name package-name)
134 (if (find #\: name)
135 name
136 (format nil "~A:~A" package-name name)))
137
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
142 :generic-function
143 :function)
144 basic-type)))
145
146 (defun skip-to (stream char)
147 (loop until (eql char (peek-char nil stream))
148 do (read-char stream)))
149
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
153 (read s) ; name
154 (read s) ; argument list/initial value
155 (skip-to s #\")
156 (list :start (file-position s)
157 :text (read s)
158 :end (file-position s))))
159
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
163 (read s) ; name
164 (read s) ; arguments/supers
165 (loop
166 (let* ((start-of-clause (file-position s))
167 (clause (read s)))
168 (when (eql (first clause) :documentation)
169 (file-position s start-of-clause)
170 (skip-to s #\()
171 (read-char s)
172 (read s) ; :DOCUMENTATION
173 (skip-to s #\")
174 (return (list :start (file-position s)
175 :text (read s)
176 :end (file-position s))))))))
177
178 (defun get-doc-function (type)
179 (case type
180 ((:function :special-variable) 'get-simple-def-docstring)
181 ((:generic-function :class) 'get-complex-def-docstring)))
182
183 (defun source-location-flatten (location-info)
184 (apply #'append (rest (find :location (rest location-info) :key #'first))))
185
186 (defvar *files*)
187
188 (defclass file ()
189 ((file-pathname :initarg :file-pathname
190 :reader file-pathname)
191 (docstrings :initform nil
192 :accessor docstrings)
193 (contents :accessor contents)))
194
195 (defmethod initialize-instance :after ((file file) &key file-pathname)
196 (setf (slot-value file 'contents) (alexandria:read-file-into-string file-pathname)))
197
198 (defun get-file (pathname)
199 (or (gethash pathname *files*)
200 (setf (gethash pathname *files*)
201 (make-instance 'file
202 :file-pathname pathname))))
203
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)))
215 (docstrings file))))
216 (2 (warn "multiple source locations for ~A" symbol-name)))))
217
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))))))
228 *files*))