0.8.0.65:
[sbcl.git] / contrib / sb-bsd-sockets / doc.lisp
1 (eval-when (:load-toplevel :compile-toplevel :execute)
2   (defpackage :db-doc (:use  :cl :asdf #+sbcl :sb-ext #+cmu :ext )))
3 (in-package :db-doc)
4 ;;; turn water into wine ^W^W^W lisp into HTML
5
6 #|
7 OK.  We need a design
8
9 1) The aim is to document the current package, given a system.
10 2) The assumption is that the system is loaded; this makes it easier to
11 do cross-references and stuff
12 3) We output HTML on *standard-output*
13 4) Hyperlink wherever useful
14 5) We're allowed to intern symbols all over the place if we like
15
16 |#
17
18 ;;; note: break badly on multiple packages
19
20
21 (defvar *symbols* nil
22   "List of external symbols to print; derived from parsing DEFPACKAGE form")
23
24
25 (defun worth-documenting-p (symbol)
26   (and symbol
27        (eql (symbol-package symbol) *package*)
28        (or (ignore-errors (find-class symbol))
29            (boundp symbol) (fboundp symbol))))
30
31 (defun linkable-symbol-p (word)
32   (labels ((symbol-char (c) (or (upper-case-p c) (digit-char-p c)
33                                 (eql c #\-))))
34     (and (every  #'symbol-char word)
35          (some #'upper-case-p word)
36          (worth-documenting-p (find-symbol word)))))
37
38 (defun markup-word (w)
39   (if (symbolp w) (setf w (princ-to-string w)))
40   (cond ((linkable-symbol-p w) 
41          (format nil "<a href=\"#~A\">~A</a>"
42                  w  w))
43         ((and (> (length w) 0)
44               (eql (elt w 0) #\_)
45               (eql (elt w (1- (length w))) #\_))
46          (format nil "<b>~A</b>" (subseq w 1 (1- (length w)))))
47         (t w)))
48 (defun markup-space (w)
49   (let ((para (search (coerce '(#\Newline #\Newline) 'string) w)))
50     (if para
51         (format nil "~A<P>~A"
52                 (subseq w 0 (1+ para))
53                 (markup-space (subseq w (1+ para) nil)))
54         w)))
55
56 (defun text-markup (text)
57   (let ((start-word 0) (end-word 0))
58     (labels ((read-word ()
59                (setf end-word
60                      (position-if
61                       (lambda (x) (member x '(#\Space #\, #\.  #\Newline)))
62                       text :start start-word))
63                (subseq text start-word end-word))
64              (read-space ()
65                (setf start-word
66                      (position-if-not
67                       (lambda (x) (member x '(#\Space #\, #\.  #\Newline)))
68                       text :start end-word ))
69                (subseq text end-word start-word)))
70       (with-output-to-string (o)
71         (loop for inword = (read-word)
72               do (princ (markup-word inword) o)
73               while (and start-word end-word)
74               do (princ (markup-space (read-space)) o)
75               while (and start-word end-word))))))
76
77
78 (defun do-defpackage (form stream)
79   (setf *symbols* nil)
80   (destructuring-bind (defn name &rest options) form
81     (when (string-equal name (package-name *package*))
82       (format stream "<h1>Package ~A</h1>~%" name)
83       (when (documentation *package* t)
84         (princ (text-markup (documentation *package* t))))
85       (let ((exports (assoc :export options)))
86         (when exports
87           (setf *symbols* (mapcar #'symbol-name (cdr exports)))))
88       1)))
89
90 (defun do-defclass (form stream)
91   (destructuring-bind (defn name super slots &rest options) form
92     (when (interesting-name-p name)
93       (let ((class  (find-class name)))
94         (format stream "<p><a name=\"~A\"><i>Class: </i><b>~A</b></a>~%"
95                 name  name)
96         #+nil (format stream "<p><b>Superclasses: </b> ~{~A ~}~%"
97                 (mapcar (lambda (x) (text-markup (class-name x)))
98                         (mop:class-direct-superclasses class)))
99         (if (documentation class 'type)
100             (format stream "<blockquote>~A</blockquote>~%"
101                     (text-markup (documentation class  'type))))
102         (when slots
103           (princ "<p><b>Slots:</b><ul>" stream)
104           (dolist (slot slots)
105             (destructuring-bind
106                   (name &key reader writer accessor initarg initform type
107                         documentation)
108                 (if (consp slot) slot (list slot))
109               (format stream "<li>~A : ~A</li>~%" name
110                       (if documentation (text-markup documentation) "")))) 
111           (princ "</ul>" stream))
112         t))))
113         
114
115 (defun interesting-name-p (name)
116   (cond ((consp name)
117          (and (eql (car name) 'setf)
118               (interesting-name-p (cadr name))))
119         (t (member (symbol-name name) *symbols* :test #'string=))))
120
121 (defun markup-lambdalist (l)
122   (let (key-p)
123     (loop for i in l
124           if (eq '&key i) do (setf key-p t)
125           end
126           if (and (not key-p) (consp i))
127           collect (list (car i) (markup-word (cadr i)))
128           else collect i)))
129
130 (defun do-defunlike (form label stream)
131   (destructuring-bind (defn name lambdalist &optional doc &rest code) form
132     (when (interesting-name-p name)
133       (when (symbolp name)
134         (setf *symbols* (remove (symbol-name name) *symbols* :test #'string=)))
135       (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>~%"
136               name  (string-downcase (princ-to-string name))
137               (string-downcase
138                (format nil "~{ ~A~}" (markup-lambdalist lambdalist)))
139               label)
140       (if (stringp doc)
141           (format stream "<blockquote>~A</blockquote>~%"
142                   (text-markup doc)))
143       t)))
144
145 (defun do-defun (form stream) (do-defunlike form "Function" stream))
146 (defun do-defmethod (form stream) (do-defunlike form "Method" stream))
147 (defun do-defgeneric (form stream) (do-defunlike form "Generic Function" stream))
148 (defun do-boolean-sockopt (form stream)
149   (destructuring-bind (type lisp-name level c-name) form
150     (pushnew (symbol-name lisp-name) *symbols*)
151
152     (do-defunlike `(defun  ,lisp-name ((socket socket) argument)
153                     ,(format nil "Return the value of the ~A socket option for SOCKET.  This can also be updated with SETF." (symbol-name c-name) ) 'empty)
154       "Accessor" stream)))
155     
156 (defun do-form (form output-stream)
157   (cond ((not (listp form)) nil)
158         ((string= (symbol-name (car form)) "DEFINE-SOCKET-OPTION-BOOL")
159          (do-boolean-sockopt form output-stream))
160         ((eq (car form) 'defclass)
161          (do-defclass form output-stream))
162         ((eq (car form) 'eval-when)
163          (do-form (third form) output-stream))
164         ((eq (car form) 'defpackage)
165          (do-defpackage form output-stream))
166         ((eq (car form) 'defun)
167          (do-defun form output-stream))
168         ((eq (car form) 'defmethod)
169          (do-defmethod form output-stream))
170         ((eq (car form) 'defgeneric)
171          (do-defgeneric form output-stream))
172         (t nil)))
173
174 (defun do-file (input-stream output-stream)
175   "Read in a Lisp program on INPUT-STREAM and make semi-pretty HTML on OUTPUT-STREAM"
176   (let ((eof-marker (gensym)))
177     (if (< 0 
178          (loop for form =  (read input-stream nil eof-marker)
179                until (eq form eof-marker)
180                if (do-form form output-stream)
181                count 1 #| and
182                do (princ "<hr width=\"20%\">" output-stream) |# ))
183         (format output-stream "<hr>"
184                 ))))
185
186 (defvar *standard-sharpsign-reader*
187   (get-dispatch-macro-character #\# #\|))
188
189 (defun document-system (system &key
190                                (output-stream *standard-output*)
191                                (package *package*))
192   "Produce HTML documentation for all files defined in SYSTEM, covering
193 symbols exported from PACKAGE"
194   (let ((*package* (find-package package))
195         (*readtable* (copy-readtable)) 
196         (*standard-output* output-stream))
197     (set-dispatch-macro-character
198      #\# #\|
199      (lambda (s c n)
200        (if (eql (peek-char nil s t nil t) #\|)
201            (princ
202             (text-markup
203              (coerce 
204               (loop with discard = (read-char s t nil t)
205                     ;initially (princ "<P>")
206                     for c = (read-char s t nil t)
207                     until (and (eql c #\|)
208                                (eql (peek-char nil s t nil t) #\#))
209                     collect c
210                     finally (read-char s t nil t))
211               'string)))
212            (funcall *standard-sharpsign-reader* s c n))))
213     (dolist (c (cclan:all-components 'sb-bsd-sockets))
214       (when (and (typep c 'cl-source-file)
215                  (not (typep c 'sb-bsd-sockets-system::constants-file)))
216         (with-open-file (in (component-pathname c) :direction :input)
217             (do-file in *standard-output*))))))
218
219 (defun start ()
220   (with-open-file (*standard-output* "index.html" :direction :output)
221       (format t "<html><head><title>SBCL BSD-Sockets API Reference</title></head><body>~%")
222       (format t
223 "<!--
224  This is a machine-generated file (from SB-BSD-SOCKETS source code, massaged
225  by doc.lisp), so do not edit it directly.
226  -->
227 ")
228       (asdf:operate 'asdf:load-op 'sb-bsd-sockets)
229       (document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))
230
231 (start)