contrib/sb-bsd-sockets/doc.lisp

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