[10d2c0]: contrib / sb-bsd-sockets / doc.lisp Maximize Restore History

Download this file

doc.lisp    226 lines (199 with data), 7.8 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
(eval-when (:load-toplevel :compile-toplevel :execute)
(defpackage :db-doc (:use :cl :asdf #+sbcl :sb-ext #+cmu :ext )))
(in-package :db-doc)
;;; turn water into wine ^W^W^W lisp into HTML
#|
OK. We need a design
1) The aim is to document the current package, given a system.
2) The assumption is that the system is loaded; this makes it easier to
do cross-references and stuff
3) We output HTML on *standard-output*
4) Hyperlink wherever useful
5) We're allowed to intern symbols all over the place if we like
|#
;;; note: break badly on multiple packages
(defvar *symbols* nil
"List of external symbols to print; derived from parsing DEFPACKAGE form")
(defun worth-documenting-p (symbol)
(and symbol
(eql (symbol-package symbol) *package*)
(or (ignore-errors (find-class symbol))
(boundp symbol) (fboundp symbol))))
(defun linkable-symbol-p (word)
(labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
(eql c #\-))))
(and (every #'symbol-char word)
(some #'upper-case-p word)
(worth-documenting-p (find-symbol word)))))
(defun markup-word (w)
(if (symbolp w) (setf w (princ-to-string w)))
(cond ((linkable-symbol-p w)
(format nil "<a href=\"#~A\">~A</a>"
w w))
((and (> (length w) 0)
(eql (elt w 0) #\_)
(eql (elt w (1- (length w))) #\_))
(format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
(t w)))
(defun markup-space (w)
(let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
(if para
(format nil "~A<P>~A"
(subseq w 0 (1+ para))
(markup-space (subseq w (1+ para) nil)))
w)))
(defun text-markup (text)
(let ((start-word 0) (end-word 0))
(labels ((read-word ()
(setf end-word
(position-if
(lambda (x) (member x '(#\Space #\, #\. #\Newline)))
text :start start-word))
(subseq text start-word end-word))
(read-space ()
(setf start-word
(position-if-not
(lambda (x) (member x '(#\Space #\, #\. #\Newline)))
text :start end-word ))
(subseq text end-word start-word)))
(with-output-to-string (o)
(loop for inword = (read-word)
do (princ (markup-word inword) o)
while (and start-word end-word)
do (princ (markup-space (read-space)) o)
while (and start-word end-word))))))
(defun do-defpackage (form stream)
(setf *symbols* nil)
(destructuring-bind (defn name &rest options) form
(when (string-equal name (package-name *package*))
(format stream "<h1>Package ~A</h1>~%" name)
(when (documentation *package* t)
(princ (text-markup (documentation *package* t))))
(let ((exports (assoc :export options)))
(when exports
(setf *symbols* (mapcar #'symbol-name (cdr exports)))))
1)))
(defun do-defclass (form stream)
(destructuring-bind (defn name super slots &rest options) form
(when (interesting-name-p name)
(let ((class (find-class name)))
(format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
name name)
#+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
(mapcar (lambda (x) (text-markup (class-name x)))
(mop:class-direct-superclasses class)))
(if (documentation class 'type)
(format stream "<blockquote>~A</blockquote>~%"
(text-markup (documentation class 'type))))
(when slots
(princ "<p><b>Slots:</b><ul>" stream)
(dolist (slot slots)
(destructuring-bind
(name &key reader writer accessor initarg initform type
documentation)
(if (consp slot) slot (list slot))
(format stream "<li>~A : ~A</li>~%" name
(if documentation (text-markup documentation) ""))))
(princ "</ul>" stream))
t))))
(defun interesting-name-p (name)
(cond ((consp name)
(and (eql (car name) 'setf)
(interesting-name-p (cadr name))))
(t (member (symbol-name name) *symbols* :test #'string=))))
(defun markup-lambdalist (l)
(let (key-p)
(loop for i in l
if (eq '&key i) do (setf key-p t)
end
if (and (not key-p) (consp i))
collect (list (car i) (markup-word (cadr i)))
else collect i)))
(defun do-defunlike (form label stream)
(destructuring-bind (defn name lambdalist &optional doc &rest code) form
(when (interesting-name-p name)
(when (symbolp name)
(setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
(format stream "<p><a name=\"~A\"><table width=\"100%\"><tr><td width=\"80%\">(~A <i>~A</i>)</td><td align=right>~A</td></tr></table>~%"
name (string-downcase (princ-to-string name))
(string-downcase
(format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
label)
(if (stringp doc)
(format stream "<blockquote>~A</blockquote>~%"
(text-markup doc)))
t)))
(defun do-defun (form stream) (do-defunlike form "Function" stream))
(defun do-defmethod (form stream) (do-defunlike form "Method" stream))
(defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream))
(defun do-boolean-sockopt (form stream)
(destructuring-bind (type lisp-name level c-name) form
(pushnew (symbol-name lisp-name) *symbols*)
(do-defunlike `(defun ,lisp-name ((socket socket) argument)
,(format nil "Return the value of the ~A socket option for SOCKET. This can also be updated with SETF." (symbol-name c-name) ) 'empty)
"Accessor" stream)))
(defun do-form (form output-stream)
(cond ((not (listp form)) nil)
((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
(do-boolean-sockopt form output-stream))
((eq (car form) 'defclass)
(do-defclass form output-stream))
((eq (car form) 'eval-when)
(do-form (third form) output-stream))
((eq (car form) 'defpackage)
(do-defpackage form output-stream))
((eq (car form) 'defun)
(do-defun form output-stream))
((eq (car form) 'defmethod)
(do-defmethod form output-stream))
((eq (car form) 'defgeneric)
(do-defgeneric form output-stream))
(t nil)))
(defun do-file (input-stream output-stream)
"Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
(let ((eof-marker (gensym)))
(if (< 0
(loop for form = (read input-stream nil eof-marker)
until (eq form eof-marker)
if (do-form form output-stream)
count 1 #| and
do (princ "<hr width=\"20%\">" output-stream) |# ))
(format output-stream "<hr>"
))))
(defvar *standard-sharpsign-reader*
(get-dispatch-macro-character #\# #\|))
(defun document-system (system &key
(output-stream *standard-output*)
(package *package*))
"Produce HTML documentation for all files defined in SYSTEM, covering
symbols exported from PACKAGE"
(let ((*package* (find-package package))
(*readtable* (copy-readtable))
(*standard-output* output-stream))
(set-dispatch-macro-character
#\# #\|
(lambda (s c n)
(if (eql (peek-char nil s t nil t) #\|)
(princ
(text-markup
(coerce
(loop with discard = (read-char s t nil t)
;initially (princ "<P>")
for c = (read-char s t nil t)
until (and (eql c #\|)
(eql (peek-char nil s t nil t) #\#))
collect c
finally (read-char s t nil t))
'string)))
(funcall *standard-sharpsign-reader* s c n))))
(dolist (c (cclan:all-components 'db-sockets))
(when (and (typep c 'cl-source-file)
(not (typep c 'db-sockets-system::constants-file)))
(with-open-file (in (component-pathname c) :direction :input)
(do-file in *standard-output*))))))
(defun start ()
(with-open-file (*standard-output* "index.html" :direction :output)
(format t "<html><head><title>SBCL BSD-Sockets API Reference</title></head><body>~%")
(asdf:operate 'asdf:load-op 'sb-bsd-sockets)
(document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))
(start)