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     (asdf:operate 'asdf:load-op 'sb-bsd-sockets)
 223     (document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))
 224
 225 (start)