Anonymous avatar Anonymous committed df847bf

Second commit, nearly ready for release.

Comments (0)

Files changed (1)

 
 (defvar *out* nil)
 (defvar *heading-level* 0)
+(defvar *heading-char* #\*)
+(defvar *line-width* 80)
+(defvar *left-margin* 0)
+(deftype =entity= () `(member :slot :generic-function :function :macro
+                              :constant :variable :class
+                              :structure :package
+                              :slot-accessor :slot-writer :slot-reader))
+
+
 (defgeneric document (sym doctype))
 
 ;; todo still unclear how to tell if a symbol is bound to a type.
 ;; eg (deftype =foo= () `(integer 0 10))
 ;; todo would be nice to try & get links to point precisely
 ;; Would also be nice to get CL symbols to link to hyperspec
+;; todo table of slots at beginning of each class def
+;; todo use to document self
+
+;;;; Utility functions ========================================================
+
+
+(defun entity->tag (entity)
+  (case entity
+    (:generic-function "generic")
+    (:function "function")
+    (:macro "macro")
+    (:variable "variable")
+    (:constant "constant")
+    (:class "class")
+    (:slot "slot")
+    (:slot-accessor "reader:writer")
+    (:slot-reader "reader")
+    (:slot-writer "writer")
+    (:structure "structure")
+    (:package "package")
+    (otherwise (error "Unknown entity type: ~S" entity))))
+
+
+(defun entity->string (entity)
+  (case entity
+    (:generic-function "generic function")
+    (:function "function")
+    (:macro "macro")
+    (:variable "variable")
+    (:constant "constant")
+    (:class "class")
+    (:slot "slot")
+    (:slot-accessor "slot accessor")
+    (:slot-reader "slot reader")
+    (:slot-writer "slot writer")
+    (:structure "structure")
+    (:package "package")
+    (otherwise (error "Unknown entity type: ~S" entity))))
+
+
+(defun symbol-accessibility (sym &optional (pkg *package*))
+  (unless (packagep pkg)
+    (setf pkg (find-package pkg)))
+  (multiple-value-bind (sym2 access) (find-symbol (string sym) pkg)
+    (declare (ignore sym2))
+    access))
+
+
+(defun list->string-with-commas (ls)
+  (with-output-to-string (s)
+    (if (cdr ls)
+        (format s "~{~A, ~}" (butlast ls)))
+    (format s "~A" (car (last ls)))))
+
+
+(defun make-specialised-lambda-list (terms specs)
+  (iterate
+    (for term in terms)
+    (for spec = (pop specs))
+    (if spec
+        (collect (list term (make-link (class-name spec) :linktype :class)))
+        (collect term))))
+
+
+(defun list-all-direct-slots (classes)
+  (let ((slots nil))
+    (iterate
+      (for c in classes)
+      (iterate
+        (for slot in (class-direct-slots c))
+        (push slot slots)))
+    slots))
+
+
+(defun list-all-indirect-slots (classes)
+  (let ((indirect-slots nil))
+    (iterate
+      (for c in classes)
+      (for direct-slots = nil)
+      (iterate
+        (for slot in (class-direct-slots c))
+        (push slot direct-slots))
+      (iterate
+        (for slot in (class-slots c))
+        (unless (find (slot-definition-name slot) direct-slots
+                      :key #'slot-definition-name)
+          (push slot indirect-slots))))
+    indirect-slots))
+
+
+(defun list-all-slot-accessors (classes)
+  (let ((slots (remove-if-not
+                (lambda (slot) (typep slot (find-class 'direct-slot-definition)))
+                (list-all-direct-slots classes))))
+    (apply #'append
+           (append (mapcar #'slot-definition-readers slots)
+                   (mapcar #'slot-definition-writers slots)))))
+
+
+(defun word-wrap (text &key (width 80) respect-newlines respect-hyphens
+		  exclude-start-char exclude-end-char)
+  "* Arguments:
+- TEXT: A string.
+- WIDTH: An integer. The width that TEXT should be wrapped to fit within.
+Default is 80.
+- RESPECT-NEWLINES: Boolean. Should newline characters within the string
+be treated as unbreakable?
+- RESPECT-HYPHENS: Boolean. Should we refrain from breaking hyphenated
+words?
+- EXCLUDE-START-CHAR: A character, or nil.
+- EXCLUDE-END-CHAR: A character, or nil.
+
+* Returns: A list of strings.
+
+* Description: Given a string TEXT, breaks the string into a series of
+smaller strings, none of which is longer than WIDTH. Returns the list of
+strings.
+
+If EXCLUDE-START-CHAR and EXCLUDE-END-CHAR are supplied, those characters
+will be treated as demarcating sections of the string whose length is to
+be ignored (treated as zero). This allows WORD-WRAP to correctly deal with
+strings that contain <hypertext>...</hypertext> metadata."
+  (iterate
+    (with counted = 0)
+    (with breakpoint = nil)
+    (with skipping = nil)
+    (for c :in-string text)
+    (for actual :upfrom 0)
+    (cond
+      ((eql c exclude-start-char)
+       (setf skipping t))
+      ((eql c exclude-end-char)
+       (setf skipping nil)))
+    (when (not skipping)
+      (incf counted)
+      (if (or (eql c #\space) (eql c #\tab)
+	      (and (eql c #\Newline) (not respect-newlines))
+	      (and (eql c #\-) (not respect-hyphens)))
+	  (setf breakpoint actual))
+      (when (and (eql c #\Newline) respect-newlines)
+	(setf breakpoint actual)
+	(setf counted (1+ width))))
+    (when (>= counted width)
+      (return (cons (substitute-if #\space
+				   #'(lambda (ch)
+				       (or (eql ch #\tab)
+					   (eql ch #\newline)))
+				   (subseq text 0
+					   (or breakpoint actual)))
+		    (word-wrap (subseq text (if breakpoint
+						(1+ breakpoint)
+						actual))
+			       :width width
+			       :respect-newlines respect-newlines
+			       :respect-hyphens respect-hyphens
+			       :exclude-start-char exclude-start-char
+			       :exclude-end-char exclude-end-char))))
+    (finally (return (list text)))))
+
+
+;;;; Formatting  ==============================================================
+
 
 (defun write-docstring (str &key (levels *heading-level*)
                         (default "Not documented."))
          (for line = (read-line in))
          (for str =
               (regex-replace-all
-               "^([\\*]+)([ \t]+)" line
+               (format nil "^([~A]+)([ \t]+)"
+                       (quote-meta-chars
+                        (format nil "~C" *heading-char*)))
+               line
                (lambda (match match1 &rest matches)
                  (declare (ignore match matches))
                  (format nil "~A "
                          (make-string (+ (length match1)
                                          (1- levels))
-                                      :initial-element #\*)))
+                                      :initial-element *heading-char*)))
                :simple-calls t))
-         (format nil "~A~%" str))))
+         (format *out* "~A~%" str))))
     (default
-     (format nil "~A~%" default))))
+     (format *out* "~A~%" default))))
 
+(defmacro write-indented ((indent) &body body)
+  `(let ((*left-margin* (+ *left-margin* ,indent)))
+     ,@body))
 
-;;;; Utility functions ========================================================
 
+(defun write-out (fmt &rest args)
+  (princ (make-string *left-margin* :initial-element #\space) *out*)
+  (apply #'format *out* fmt args))
 
-(defun symbol-accessibility (sym &optional (pkg *package*))
-  (unless (packagep pkg)
-    (setf pkg (find-package pkg)))
-  (multiple-value-bind (sym2 access) (find-symbol (string sym) pkg)
-    (declare (ignore sym2))
-    access))
 
-
-(defun list->string-with-commas (ls)
-  (with-output-to-string (s)
-    (if (cdr ls)
-        (format s "~{~A, ~}" (butlast ls)))
-    (format s "~A" (car (last ls)))))
-
-
-(defun make-specialised-lambda-list (terms specs)
-  (iterate
-    (for term in terms)
-    (for spec = (pop specs))
-    (if spec
-        (collect (list term (make-link (class-name spec))))
-        (collect term))))
-
-
-(defun list-all-slots (classes)
-  (let ((slots nil))
-    (iterate
-      (for c in classes)
-      (iterate
-        (for slot in (class-direct-slots c))
-        (push slot slots)))
-    slots))
-
-
-(defun list-all-slot-accessors (classes)
-  (let ((slots (remove-if-not
-                (lambda (slot) (typep slot (find-class 'direct-slot-definition)))
-                (list-all-slots classes))))
-    (apply #'append
-           (append (mapcar #'slot-definition-readers slots)
-                   (mapcar #'slot-definition-writers slots)))))
-
-
-;;;; Formatting  ==============================================================
-
-
-(defmacro writing-section ((title &optional sym) &body body)
-  `(let ((*heading-level* (1+ *heading-level*)))
-     ,(if sym
-          `(format *out* "~&~A ~A: <<~A>>~%~%"
-                  (make-string *heading-level* :initial-element #\*)
-                  ,title ,sym)
-          `(format *out* "~&~A ~A~%~%"
-                   (make-string *heading-level* :initial-element #\*)
-                   ,title))
-     ,@(if sym
-           `((format *out* "  :PROPERTIES:~%")
-             (format *out* "  :CATEGORY: ~A~%" ,title)
-             (format *out* "  :END:~%~%")))
-     ,@body
-     (terpri *out*)))
-
+(defun write-heading (title)
+  (format *out* "~&~A ~A~%~%"
+           (make-string *heading-level* :initial-element *heading-char*)
+           title))
 
 
 (defun make-link (str &key text linktype)
-  (if linktype
-      (setf str (concatenate 'string linktype ":" str)))
+  (when linktype
+      (unless text
+        (setf text str))
+      (setf str (concatenate 'string (string linktype) " " (string str)))
+      (unless text
+        (setf text str)))
   (cond
     (text
      (format nil "[[~A][~A]]" str text))
     (t
      (format nil "[[~A]]" str))))
 
-  
+
+(defun make-class-link (sym)
+  (make-link sym :linktype :class))
+
+
+(defun make-package-link (sym)
+  (make-link sym :linktype :package))
+
+
+(defun write-list-as-paragraph (ls)
+  (dolist (line (word-wrap 
+                 (list->string-with-commas ls)
+                 :width *line-width*))
+    (write-out line)))
+
+
+    
+(defmacro writing-section ((entity &optional sym) &body body)
+    `(let* ((*heading-level* (1+ *heading-level*))
+            (%title ,entity)
+            (%entity %title))
+       (declare (ignorable %entity %title))
+       ,(if sym
+            `(let ((str (format nil "~:(~A~): ~(~A~)"
+                                (entity->string %entity) ,sym)))
+               (write-heading (format nil "~A~V<~A~>" str
+                                      (- *line-width* (length str))
+                                      (format nil ":~A:"
+                                              (entity->tag %entity))))
+               (write-out "# link target: ~A" (make-target ,sym %entity)))
+            `(write-heading (format nil "~:(~A~)" %title)))
+       ;; ,@(if sym
+       ;;       `((format *out* "  :PROPERTIES:~%")
+       ;;         (format *out* "  :CATEGORY: ~A~%" ,title)
+       ;;         (format *out* "  :END:~%~%")))
+       ,@body
+       (terpri *out*)))
+
+
+(defun make-target (sym entity)
+  (format nil "~(<<~A ~A>>~)" entity sym))
+
+
+(defmacro writing-bulleted-list (&body body)
+  `(progn
+     ,@body
+     (terpri *out*)))
+
+
+(defun write-bullet-point (fmt &rest args)
+  (apply #'format *out* (concatenate 'string "~&- " fmt "~&") args))
+
+
 
 (defmethod document :after ((sym symbol) (doctype t))
   (terpri *out*))
   
 
 (defmethod document ((sym symbol) (doctype (eql 'function)))
-  (writing-section ("function" sym)
+  (writing-section (:function sym)
     ;; We don't impose any structure (headings) on FUNCTION docstrings,
     ;; because functions are pretty opaque. It is up to the user to
     ;; write everything in the docstring.
 
 
 (defmethod document ((sym symbol) (doctype (eql 'macro)))
-  (writing-section ("macro" sym)
+  (writing-section (:macro sym)
     ;; The same goes for macros.
     (write-docstring (documentation sym 'function))))
 
 
 (defmethod document ((sym symbol) (doctype (eql 'var)))
-  (writing-section ("variable" sym)
+  (writing-section (:variable sym)
     (writing-section ("Value")
       (cond
         ((boundp sym)
-         (format *out* "~S~%" sym)
-         (format *out* "~A~%" (type-of sym)))
+         (format *out* "~S~%" (symbol-value sym))
+         (format *out* "Type: ~A~%" (type-of (symbol-value sym))))
         (t
          (format *out* "Unbound.~%"))))
     (writing-section ("Description")
 
 
 (defmethod document ((sym symbol) (doctype (eql 'constant)))
-  (writing-section ("constant" sym)
+  (writing-section (:constant sym)
     (writing-section ("Value")
       (cond
         ((boundp sym)
-         (format *out* "~S~%" sym)
-         (format *out* "~A~%" (type-of sym)))
+         (format *out* "~S~%" (symbol-value sym))
+         (format *out* "Type: ~A~%" (type-of (symbol-value sym))))
         (t
          (format *out* "Unbound.~%"))))
     (writing-section ("Description")
 
 (defmethod document ((sym symbol) (doctype (eql 'generic)))
   (let ((gf (symbol-function sym)))
-    (writing-section ("generic-function" sym)
+    (writing-section (:generic-function sym)
       (writing-section ("Usage")
-        (format *out* "(~A ~{~A~})~%"
+        (format *out* "~((~A~{ ~A~})~)~%"
                 sym
                 (generic-function-lambda-list gf)))
       (writing-section ("Description")
           (document m 'method))))))
 
 
+
+(defmethod document ((sym symbol) (doctype (eql 'slot-reader)))
+  (let ((gf (symbol-function sym)))
+    (writing-section (:slot-reader sym)
+      (writing-section ("Usage")
+        (format *out* "~((~A~{ ~A~})~)~%"
+                sym
+                (generic-function-lambda-list gf)))
+      (when (documentation gf t)
+        (writing-section ("Description")
+          (write-docstring (documentation gf t))))
+      (writing-section ("Methods")
+        (dolist (m (generic-function-methods gf))
+          (document m 'method))))))
+
+
+
+(defmethod document ((sym symbol) (doctype (eql 'slot-writer)))
+  (let ((gf (symbol-function sym)))
+    (writing-section (:slot-writer sym)
+      (writing-section ("Usage")
+        (format *out* "~((~A~{ ~A~})~)~%"
+                sym
+                (generic-function-lambda-list gf)))
+      (when (documentation gf t)
+        (writing-section ("Description")
+          (write-docstring (documentation gf t))))
+      (writing-section ("Methods")
+        (dolist (m (generic-function-methods gf))
+          (document m 'method))))))
+
+
+(defmethod document ((sym symbol) (doctype (eql 'slot-accessor)))
+  (let ((gf (symbol-function sym)))
+    (writing-section (:slot-accessor sym)
+      (writing-section ("Usage")
+        (format *out* "~((~A~{ ~A~})~)~%"
+                sym
+                (generic-function-lambda-list gf)))
+      (when (documentation gf t)
+        (writing-section ("Description")
+          (write-docstring (documentation gf t))))
+      (writing-section ("Methods")
+        (dolist (m (generic-function-methods gf))
+          (document m 'method))))))
+
+
+
+
 (defmethod document ((m standard-method) (doctype (eql 'method)))
   ;; Methods are just briefly documented, 1-2 lines each.
-  (format *out* "- ~A ~A~A~%"
-          (generic-function-name (method-generic-function m))
-          (or (format nil "~S " (method-qualifiers m)) "")
-          (make-specialised-lambda-list 
-           (method-lambda-list m)
-           (method-specializers m)))
+  (write-bullet-point
+   "(~(~A~A~{ ~A~}~))"
+   (generic-function-name (method-generic-function m))
+   (if (method-qualifiers m)
+       (format nil "~S " (method-qualifiers m))
+       "")
+   (make-specialised-lambda-list 
+    (method-lambda-list m)
+    (method-specializers m)))
   (if (and (slot-exists-p m 'documentation)
            (slot-boundp m 'documentation)
            (documentation m t))
-      ;; todo indent this
-      (write-docstring (documentation m t))))
+      (write-indented (4)
+        (write-docstring (documentation m t)))))
 
 
 
 (defmethod document ((m cl:standard-method) (doctype (eql 'method)))
-  (format *out* "- ~A ~A~A~%"
-          (generic-function-name (method-generic-function m))
-          (or (format nil "~S " (method-qualifiers m)) "")
-          (make-specialised-lambda-list 
-           (method-lambda-list m)
-           (method-specializers m)))
+  (write-bullet-point
+   "(~(~A~A~{ ~A~}~))"
+   (generic-function-name (method-generic-function m))
+   (if (method-qualifiers m)
+       (format nil "~S " (method-qualifiers m))
+       "")
+   (make-specialised-lambda-list 
+    (method-lambda-list m)
+    (method-specializers m)))
   (if (and (slot-exists-p m 'documentation)
            (slot-boundp m 'documentation)
            (documentation m t))
-      ;; todo indent this
-      (write-docstring (documentation m t))))
+      (write-indented (4)
+        (write-docstring (documentation m t)))))
 
 
 
 (defmethod document ((sym symbol) (doctype (eql 'class)))
   (let* ((c (find-class sym))
          (struct? (typep c (find-class 'structure-class))))
-    (writing-section ((if struct? "structure" "class") sym)
-      (handler-case
-          (progn
-            (unless (class-finalized-p c)
-              (error "Not finalised"))
-            (unless struct?
-              (writing-section ("Family Tree")
-                ;; todo word wrap these
-                (format *out* "- Parent classes: ~A~%"
-                        (list->string-with-commas
-                         (mapcar #'make-link
-                                 (mapcar
-                                  #'class-name
-                                  (class-direct-superclasses c)))))
-                (format *out* "- Precedence list: ~A~%"
-                        (list->string-with-commas
-                         (mapcar #'make-link
-                                 (mapcar
-                                  #'class-name
-                                  (class-precedence-list c)))))
-                (format *out* "- Direct subclasses: ~A~%"
-                        (list->string-with-commas
-                         (mapcar #'make-link
-                                 (mapcar
-                                  #'class-name
-                                  (class-direct-subclasses c)))))))
-            (writing-section ("Description")
-              (write-docstring (documentation c t)))
-            (writing-section ("Direct slots")
-              (dolist (slot (class-direct-slots c))
-                (document slot 'slot)))
-            (writing-section ("Indirect slots")
-              ;; todo need INDIRECT rather than all 
-              (dolist (slot (class-slots c))
-                (document slot 'slot))))
-        (error ()
-          (format *out* "(not finalised)~%"))))))
+    (writing-section ((if struct? :structure :class) sym)
+      (progn
+        (unless (class-finalized-p c)
+          (error "Not finalised"))
+        (unless struct?
+          (writing-section ("Inheritance")
+            ;; todo word wrap these
+            (write-bullet-point "Parent classes:")
+            (write-indented (4)
+              (write-list-as-paragraph
+               (mapcar #'make-class-link
+                       (mapcar
+                        #'string-downcase
+                        (mapcar
+                         #'class-name
+                         (class-direct-superclasses c))))))
+            (write-bullet-point "Precedence list:")
+            (write-indented (4)                
+              (write-list-as-paragraph
+               (mapcar #'make-class-link
+                       (mapcar
+                        #'string-downcase
+                        (mapcar
+                         #'class-name
+                         (class-precedence-list c))))))
+            (write-bullet-point "Direct subclasses:")
+            (write-indented (4)                
+              (write-list-as-paragraph
+               (mapcar #'make-class-link
+                       (mapcar
+                        #'string-downcase
+                        (mapcar
+                         #'class-name
+                         (class-direct-subclasses c))))))))
+        (writing-section ("Description")
+          (write-docstring (documentation c t)))
+        (writing-section ("Direct slots")
+          (dolist (slot (class-direct-slots c))
+            (document slot 'slot)))
+        (when (list-all-indirect-slots (list c))
+          (writing-section ("Indirect slots")
+            (dolist (slot (list-all-indirect-slots (list c)))
+              (document slot 'slot))))))))
+
 
 
 (defmethod document :around ((slot slot-definition)
                              (doctype (eql 'slot)))
-  (writing-section ("slot" (slot-definition-name slot))
-    (format *out* "- Value type: ~A~%"
-            (slot-definition-type slot))
-    (format *out* "- Initial value: ~S~%"
-            (slot-definition-initform slot))
-    (format *out* "- Initargs: ~S~%"
-            (slot-definition-initargs slot))
-    (format *out* "- Allocation: ~A~%"
-            (slot-definition-allocation slot))
+  (writing-section (:slot (slot-definition-name slot))
+    (writing-bulleted-list
+     (write-bullet-point "Value type: ~A"
+                         (slot-definition-type slot))
+     (write-bullet-point "Initial value: ~S"
+                         (slot-definition-initform slot))
+     (write-bullet-point "Initargs: ~S"
+                         (slot-definition-initargs slot))
+     (write-bullet-point "Allocation: ~A"
+                         (slot-definition-allocation slot)))
     (if (and (slot-boundp slot 'documentation)
              (documentation slot t))
         (writing-section ("Description")
     (when (remove-if #'listp accessors)
       (writing-section ("Accessors")
         (dolist (fname (remove-if #'listp accessors))
-          (format *out* "~A~%" (make-link fname)))))
+          (document fname 'slot-accessor))))
     (when readers
       (writing-section ("Readers")
         (dolist (fname readers)
-          (format *out* "~A~%" (make-link fname)))))
+          (document fname 'slot-reader))))
     (when writers
       (writing-section ("Writers")
         (dolist (fname writers)
-          (format *out* "~A~%" (make-link fname)))))))
+          (document fname 'slot-writer))))))
 
 
 ;;;; Toplevel =================================================================
       (setf pkg (find-package pkg)))
     (do-symbols (sym pkg)
       (setf access (symbol-accessibility sym pkg))
-      (when (eql accessibility access)
+      (when (and (not (find sym (package-shadowing-symbols pkg)))
+                 (eql accessibility access))
         (if (find-class sym nil)
             (push sym classes))
         (cond
       (document sym 'constant))))
 
 
-(defun docpkg (pkgname)
+(defun docpkg (&rest pkgnames)
   (let ((*out* *standard-output*))
     ;; todo documentation for the package
     ;; todo document multiple packages in one file?
-    (format *out* "Package: ~A~%~%" (package-name (find-package pkgname)))
-    (document-package-contents pkgname :external)
-    (document-package-contents pkgname :internal)))
+    (dolist (pkg (mapcar #'find-package pkgnames))
+      (writing-section (:package (package-name pkg))
+        (writing-bulleted-list
+          (write-bullet-point "Uses:")
+          (write-indented (4)
+            (write-list-as-paragraph
+             (mapcar #'make-package-link
+                     (mapcar #'string-downcase
+                     (mapcar #'package-name (package-use-list pkg))))))
+          (write-bullet-point "Used by:")
+          (write-indented (4)
+            (write-list-as-paragraph
+             (mapcar #'make-package-link
+                     (mapcar #'string-downcase
+                     (mapcar #'package-name (package-used-by-list pkg)))))))
+        (document-package-contents pkg :external)
+        (document-package-contents pkg :internal)))))
 
 
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.