Anonymous avatar Anonymous committed 3a5b1b6

Output disambigution sections for symbols with multiple uses.
EQL-SPECIALIZERs are described with their specialising value.
If a docstring contains "* " at the beginning, it is NOT wrapped in a "Description:" section.
Output package docstrings.
Other tidying up.

Comments (0)

Files changed (1)

 
 (in-package :clod)
 
-(defvar *out* nil
+(defvar *out* *standard-output*
   "* Description
 Global variable that is bound to the output stream used by CLOD
 when writing documentation.")
 (defvar *left-margin* 0
   "* Description
 Number of spaces to which text is currently being indented.")
+(defvar *ambiguities* nil)
+
 (deftype =entity= ()
   "* Description
 Type for entities."
 Write a section documenting the entity named SYM which is of entity type
 DOCTYPE."))
 
-;; todo still unclear how to tell if a symbol is bound to a type.
+;; 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 would be nice to get CL symbols to link to hyperspec
+;;    (if (eql (symbol-package sym) (find-package :cl)) ...)
 ;; todo table of slots at beginning of each class def
 ;; todo use to document self
+;; todo need to escape org format chars in symbols: *, / etc
 
 ;;;; Utility functions ========================================================
 
     (for term in terms)
     (for spec = (pop specs))
     (if spec
-        (collect (list term (make-link (if (typep spec 'class)
-                                           (class-name spec)
-                                           (class-name (class-of spec)))
-                                       :linktype :class)))
+        (collect (list term (make-class-link spec)))
+        ;; else
         (collect term))))
 
 
 
 (defun word-wrap (text &key (width 80) respect-newlines respect-hyphens
 		  exclude-start-char exclude-end-char)
-  "* Arguments:
+  "* Arguments
 - TEXT: A string.
 - WIDTH: An integer. The width that TEXT should be wrapped to fit within.
 Default is 80.
 - EXCLUDE-START-CHAR: A character, or nil.
 - EXCLUDE-END-CHAR: A character, or nil.
 
-* Returns: A list of strings.
+* Returns
+A list of strings.
 
-* Description: Given a string TEXT, breaks the string into a series of
+* 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.
 
 
 
 (defun write-out (fmt &rest args)
+  (fresh-line *out*)
   (princ (make-string *left-margin* :initial-element #\space) *out*)
   (apply #'format *out* fmt args))
 
            title))
 
 
+(defun type->string (typ)
+  (format nil "~A"
+          (cond
+            ((listp typ)
+             (car typ))
+            (t
+             typ))))
+
+
 (defun make-link (str &key text linktype)
   (when linktype
       (unless text
         (setf text str)))
   (cond
     (text
-     (format nil "[[~A][~A]]" str text))
+     (format nil "~([[~A][~A]]~)" str text))
     (t
-     (format nil "[[~A]]" str))))
+     (format nil "~([[~A]]~)" str))))
 
 
-(defun make-class-link (sym)
+(defmethod make-class-link ((sym symbol))
   (make-link sym :linktype :class))
 
+(defmethod make-class-link ((str string))
+  (make-link str :linktype :class))
+
+(defmethod make-class-link ((c class))
+  (make-link (class-name c) :linktype :class))
+
+(defmethod make-class-link ((o standard-object))
+  (make-link (class-name (class-of o)) :linktype :class))
+
+(defmethod make-class-link ((c eql-specializer))
+  (format nil "~S" `(eql ,(eql-specializer-object c))))
+
+
 
 (defun make-package-link (sym)
   (make-link sym :linktype :package))
                                       (- *line-width* (length str))
                                       (format nil ":~A:"
                                               (entity->tag %entity))))
-               (write-out "# link target: ~A" (make-target ,sym %entity)))
+               (write-out "# link target: ~A~%~%" (make-target ,sym %entity)))
             `(write-heading (format nil "~:(~A~)" %title)))
        ;; ,@(if sym
        ;;       `((format *out* "  :PROPERTIES:~%")
        (terpri *out*)))
 
 
-(defun make-target (sym entity)
-  (format nil "~(<<~A ~A>>~)" entity sym))
+(defun write-docstring-section (title docstr)
+  (if (and (stringp docstr)
+           (eql 0 (search (format nil "~C " *heading-char*) docstr)))
+      (write-docstring docstr :levels (1+ *heading-level*))
+      (writing-section (title)
+        (write-docstring docstr))))
+
+
+(defun make-target (sym &optional entity)
+  (if entity
+      (format nil "~(<<~A ~A>>~)" entity sym)
+      (format nil "~(<<~A>>~)" sym)))
 
 
 (defmacro writing-bulleted-list (&body body)
     (write-docstring (documentation sym 'function))))
 
 
+
 (defmethod document ((sym symbol) (doctype (eql 'var)))
   (writing-section (:variable sym)
     (writing-section ("Value")
       (cond
         ((boundp sym)
          (format *out* "~S~%" (symbol-value sym))
-         (format *out* "Type: ~A~%" (type-of (symbol-value sym))))
+         (format *out* "Type: ~(~A~)~%" (type->string (type-of (symbol-value sym)))))
         (t
          (format *out* "Unbound.~%"))))
-    (writing-section ("Description")
-      (write-docstring (documentation sym 'variable)))))
+    (write-docstring-section "Description" (documentation sym 'variable))))
 
 
 (defmethod document ((sym symbol) (doctype (eql 'constant)))
       (cond
         ((boundp sym)
          (format *out* "~S~%" (symbol-value sym))
-         (format *out* "Type: ~A~%" (type-of (symbol-value sym))))
+         (format *out* "Type: ~(~A~)~%" (type->string (type-of (symbol-value sym)))))
         (t
          (format *out* "Unbound.~%"))))
-    (writing-section ("Description")
-      (write-docstring (documentation sym 'variable)))))
+    (write-docstring-section "Description" (documentation sym 'variable))))
 
 
 (defmethod document ((sym symbol) (doctype (eql 'generic)))
         (format *out* "~((~A~{ ~A~})~)~%"
                 sym
                 (generic-function-lambda-list gf)))
-      (writing-section ("Description")
-        (write-docstring (documentation gf t)))
+      (write-docstring-section "Description" (documentation gf t))
       ;; No portable way for method-combination objects to introspect.
       ;;(format *out* "  Combination: ~S~%"
       ;;        (generic-function-method-combination gf))
                 sym
                 (generic-function-lambda-list gf)))
       (when (documentation gf t)
-        (writing-section ("Description")
-          (write-docstring (documentation gf t))))
+        (write-docstring-section "Description" (documentation gf t)))
       (writing-section ("Methods")
         (dolist (m (generic-function-methods gf))
           (document m 'method))))))
                 sym
                 (generic-function-lambda-list gf)))
       (when (documentation gf t)
-        (writing-section ("Description")
-          (write-docstring (documentation gf t))))
+        (write-docstring-section "Description" (documentation gf t)))
       (writing-section ("Methods")
         (dolist (m (generic-function-methods gf))
           (document m 'method))))))
                 sym
                 (generic-function-lambda-list gf)))
       (when (documentation gf t)
-        (writing-section ("Description")
-          (write-docstring (documentation gf t))))
+        (write-docstring-section "Description" (documentation gf t)))
       (writing-section ("Methods")
         (dolist (m (generic-function-methods gf))
           (document m 'method))))))
    "(~(~A~A~{ ~A~}~))"
    (generic-function-name (method-generic-function m))
    (if (method-qualifiers m)
-       (format nil "~S " (method-qualifiers m))
+       (format nil "~{ ~S~}" (method-qualifiers m))
        "")
    (make-specialised-lambda-list 
     (method-lambda-list m)
    "(~(~A~A~{ ~A~}~))"
    (generic-function-name (method-generic-function m))
    (if (method-qualifiers m)
-       (format nil "~S " (method-qualifiers m))
+       (format nil "~{ ~S~}" (method-qualifiers m))
        "")
    (make-specialised-lambda-list 
     (method-lambda-list m)
             (write-bullet-point "Parent classes:")
             (write-indented (4)
               (write-list-as-paragraph
-               (mapcar #'make-class-link
-                       (mapcar
-                        #'string-downcase
+               (or
+                (mapcar #'make-class-link
                         (mapcar
-                         #'class-name
-                         (class-direct-superclasses c))))))
+                         #'string-downcase
+                         (mapcar
+                          #'class-name
+                          (class-direct-superclasses c))))
+                (list "None."))))
             (write-bullet-point "Precedence list:")
             (write-indented (4)                
               (write-list-as-paragraph
-               (mapcar #'make-class-link
-                       (mapcar
-                        #'string-downcase
+               (or
+                (mapcar #'make-class-link
                         (mapcar
-                         #'class-name
-                         (class-precedence-list c))))))
+                         #'string-downcase
+                         (mapcar
+                          #'class-name
+                          (class-precedence-list c))))
+                (list "None."))))
             (write-bullet-point "Direct subclasses:")
             (write-indented (4)                
               (write-list-as-paragraph
-               (mapcar #'make-class-link
-                       (mapcar
-                        #'string-downcase
+               (or 
+                (mapcar #'make-class-link
                         (mapcar
-                         #'class-name
-                         (class-direct-subclasses c))))))))
-        (writing-section ("Description")
-          (write-docstring (documentation c t)))
+                         #'string-downcase
+                         (mapcar
+                          #'class-name
+                          (class-direct-subclasses c))))
+                (list "None."))))))
+        (write-docstring-section "Description" (documentation c t))
         (writing-section ("Direct slots")
           (dolist (slot (class-direct-slots c))
             (document slot 'slot)))
                              (doctype (eql 'slot)))
   (writing-section (:slot (slot-definition-name slot))
     (writing-bulleted-list
-     (write-bullet-point "Value type: ~A"
+     (write-bullet-point "Value type: ~(~A~)"
                          (slot-definition-type slot))
-     (write-bullet-point "Initial value: ~S"
+     (write-bullet-point "Initial value: ~(~S~)"
                          (slot-definition-initform slot))
-     (write-bullet-point "Initargs: ~S"
-                         (slot-definition-initargs slot))
-     (write-bullet-point "Allocation: ~A"
+     (write-bullet-point "Initargs: ~(~A~)"
+                         (if (slot-definition-initargs slot)
+                             (list->string-with-commas
+                              (slot-definition-initargs slot))
+                             'none))
+     (write-bullet-point "Allocation: ~(~A~)"
                          (slot-definition-allocation slot)))
     (if (and (slot-boundp slot 'documentation)
              (documentation slot t))
-        (writing-section ("Description")
-          (write-docstring (documentation slot t))))
+        (write-docstring-section "Description" (documentation slot t)))
     (call-next-method)))
     
 
 
 
 (defun document-package-contents (pkg &optional (accessibility :external))
-  (let ((access nil)
+  (let ((access nil) (uses nil)
         (functions nil)
         (generics nil)
         (macros nil)
         (classes nil))  ;; structures are actually classes too
     (unless (packagep pkg)
       (setf pkg (find-package pkg)))
+    (setf *ambiguities* (make-hash-table :test #'eql))
     (do-symbols (sym pkg)
+      (setf uses nil)
       (setf access (symbol-accessibility sym pkg))
       (when (and (not (find sym (package-shadowing-symbols pkg)))
                  (eql accessibility access))
-        (if (find-class sym nil)
-            (push sym classes))
+        (when (find-class sym nil)
+          (push sym classes)
+          (push :class uses))
         (cond
           ((macro-function sym)
-           (push sym macros))
+           (push sym macros)
+           (push :macro uses))
           ((and (fboundp sym)
                 (typep (fboundp sym) (find-class 'generic-function)))
-           (push sym generics))
+           (push sym generics)
+           (push :generic-function uses))
           ((fboundp sym)
-           (push sym functions)))
+           (push sym functions)
+           (push :function uses)))
         (cond
           ((and (boundp sym)
                 (constantp sym))
-           (push sym constants))
+           (push sym constants)
+           (push :constant uses))
           ((boundp sym)
-           (push sym vars)))))
+           (push sym vars)
+           (push :variable uses)))
+        (if (> (length uses) 1)
+            (setf (gethash sym *ambiguities*) (copy-list uses)))))
     ;; Remove any generic functions that represent slot accessors
     (setf generics
           (set-difference generics
     (dolist (sym vars)
       (document sym 'var))
     (dolist (sym constants)
-      (document sym 'constant))))
+      (document sym 'constant))
+    (iterate
+      (for (sym uses) in-hashtable *ambiguities*)
+      (writing-section (sym)
+        (write-out "# target: ~A~%" (make-target (string sym)))
+        (write-out "Disambiguation.~%~%")
+        (writing-bulleted-list
+          (iterate
+            (for use in uses)
+            (write-bullet-point "~:(~A~): ~A" (entity->string use)
+                                (string-downcase
+                                 (make-link (string sym) :linktype use)))))))))
 
 
 (defun docpkg (&rest pkgnames)
-  (let ((*out* *standard-output*))
     ;; todo documentation for the package
     ;; todo document multiple packages in one file?
     (dolist (pkg (mapcar #'find-package pkgnames))
                      (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)))))))
+            (cond
+              ((package-used-by-list pkg)
+               (write-list-as-paragraph
+                (mapcar #'make-package-link
+                        (mapcar #'string-downcase
+                                (mapcar #'package-name (package-used-by-list pkg))))))
+              (t
+               (write-out "None.")))))
+        (write-docstring-section "Description" (documentation pkg t))
         (document-package-contents pkg :external)
-        (document-package-contents pkg :internal)))))
+        (document-package-contents pkg :internal))))
 
 
+(defun docpkg-file (filename &rest pkgnames)
+  (with-open-file (*out* filename :direction :output :if-exists :supersede)
+    (apply #'docpkg pkgnames)))
+
 
 ;;;; Test package =============================================================
 
 (defun foofun (x y)
   "A function."
   (+ x y))
+(defvar foofun #\x)
 (defclass <foo> ()
   ((fooslot :initform 0 :accessor fooslot))
   (:documentation "A class."))
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.