Component doc

You are here: All Systems / sb-bsd-sockets / doc

;;;; the old documentation extracted / generator for db-sockets / sb-bsd-sockets
;;;;
;;;; Not used anymore as the documentation is now integrated into the user manual,
;;;; but I didn't have heart yet to delete this. -- NS 20040801

(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 'sb-bsd-sockets))
      (when (and (typep c 'cl-source-file)
                 (not (typep c 'sb-bsd-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>~%")
      (format t
"<!--
 This is a machine-generated file (from SB-BSD-SOCKETS source code, massaged
 by doc.lisp), so do not edit it directly.
 -->
")
      (asdf:operate 'asdf:load-op 'sb-bsd-sockets)
      (document-system 'sb-bsd-sockets :package :sb-bsd-sockets)))

(start)

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.