Commits

Paul Sexton  committed 6a8d799

First commit

  • Participants

Comments (0)

Files changed (2)

+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
+
+(defpackage #:clod-asd
+  (:use :cl :asdf))
+
+(in-package :clod-asd)
+
+(defsystem clod
+  :name "clod"
+  :version "0.0.1"
+  :author "Paul Sexton"
+  :description "Common Lisp Autodoc generator"
+  :serial t	; Only true for the simple case	.
+  :components 
+  ((:file "clod")) 
+  :depends-on ("iterate" "closer-mop" "cl-ppcre"))
+
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;;;;;;;;;;;;;;;80
+
+(in-package :cl-user)
+
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(defpackage :clod
+  (:use :cl :iterate :closer-mop :cl-ppcre)
+  (:shadowing-import-from :closer-mop
+                          #:standard-method
+                          #:standard-generic-function
+                          #:defmethod
+                          #:defgeneric
+                          #:standard-class))
+
+(in-package :clod)
+
+(defvar *out* nil)
+(defvar *heading-level* 0)
+(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
+
+(defun write-docstring (str &key (levels *heading-level*)
+                        (default "Not documented."))
+  (cond
+    (str
+     (with-input-from-string (in str)
+       (iterate
+         (while (listen in))
+         (for line = (read-line in))
+         (for str =
+              (regex-replace-all
+               "^([\\*]+)([ \t]+)" line
+               (lambda (match match1 &rest matches)
+                 (declare (ignore match matches))
+                 (format nil "~A "
+                         (make-string (+ (length match1)
+                                         (1- levels))
+                                      :initial-element #\*)))
+               :simple-calls t))
+         (format nil "~A~%" str))))
+    (default
+     (format nil "~A~%" default))))
+
+
+;;;; Utility functions ========================================================
+
+
+(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 make-link (str &key text linktype)
+  (if linktype
+      (setf str (concatenate 'string linktype ":" str)))
+  (cond
+    (text
+     (format nil "[[~A][~A]]" str text))
+    (t
+     (format nil "[[~A]]" str))))
+
+  
+
+(defmethod document :after ((sym symbol) (doctype t))
+  (terpri *out*))
+  
+
+(defmethod document ((sym symbol) (doctype (eql 'function)))
+  (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.
+    (write-docstring (documentation sym 'function))))
+
+
+(defmethod document ((sym symbol) (doctype (eql 'macro)))
+  (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 ("Value")
+      (cond
+        ((boundp sym)
+         (format *out* "~S~%" sym)
+         (format *out* "~A~%" (type-of sym)))
+        (t
+         (format *out* "Unbound.~%"))))
+    (writing-section ("Description")
+      (write-docstring (documentation sym 'variable)))))
+
+
+(defmethod document ((sym symbol) (doctype (eql 'constant)))
+  (writing-section ("constant" sym)
+    (writing-section ("Value")
+      (cond
+        ((boundp sym)
+         (format *out* "~S~%" sym)
+         (format *out* "~A~%" (type-of sym)))
+        (t
+         (format *out* "Unbound.~%"))))
+    (writing-section ("Description")
+      (write-docstring (documentation sym 'variable)))))
+
+
+(defmethod document ((sym symbol) (doctype (eql 'generic)))
+  (let ((gf (symbol-function sym)))
+    (writing-section ("generic-function" sym)
+      (writing-section ("Usage")
+        (format *out* "(~A ~{~A~})~%"
+                sym
+                (generic-function-lambda-list gf)))
+      (writing-section ("Description")
+        (write-docstring (documentation gf t)))
+      ;; No portable way for method-combination objects to introspect.
+      ;;(format *out* "  Combination: ~S~%"
+      ;;        (generic-function-method-combination gf))
+      (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)))
+  (if (and (slot-exists-p m 'documentation)
+           (slot-boundp m 'documentation)
+           (documentation m t))
+      ;; todo indent this
+      (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)))
+  (if (and (slot-exists-p m 'documentation)
+           (slot-boundp m 'documentation)
+           (documentation m t))
+      ;; todo indent this
+      (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)~%"))))))
+
+
+(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))
+    (if (and (slot-boundp slot 'documentation)
+             (documentation slot t))
+        (writing-section ("Description")
+          (write-docstring (documentation slot t))))
+    (call-next-method)))
+    
+
+(defmethod document ((slot effective-slot-definition)
+                     (doctype (eql 'slot)))
+  ;; These seem to be 'indirect' slots? They lack a lot of
+  ;; information.
+  nil)
+
+
+(defmethod document ((slot direct-slot-definition)
+                     (doctype (eql 'slot)))
+  (let* ((accessors (union (slot-definition-readers slot)
+                           (slot-definition-writers slot)))
+         (readers (set-difference (slot-definition-readers slot)
+                                  accessors :test 'equal))
+         (writers (set-difference (slot-definition-writers slot)
+                                  accessors :test 'equal)))
+    (when (remove-if #'listp accessors)
+      (writing-section ("Accessors")
+        (dolist (fname (remove-if #'listp accessors))
+          (format *out* "~A~%" (make-link fname)))))
+    (when readers
+      (writing-section ("Readers")
+        (dolist (fname readers)
+          (format *out* "~A~%" (make-link fname)))))
+    (when writers
+      (writing-section ("Writers")
+        (dolist (fname writers)
+          (format *out* "~A~%" (make-link fname)))))))
+
+
+;;;; Toplevel =================================================================
+
+
+(defun document-package-contents (pkg &optional (accessibility :external))
+  (let ((access nil)
+        (functions nil)
+        (generics nil)
+        (macros nil)
+        (vars nil)
+        (constants nil)
+        (classes nil))  ;; structures are actually classes too
+    (unless (packagep pkg)
+      (setf pkg (find-package pkg)))
+    (do-symbols (sym pkg)
+      (setf access (symbol-accessibility sym pkg))
+      (when (eql accessibility access)
+        (if (find-class sym nil)
+            (push sym classes))
+        (cond
+          ((macro-function sym)
+           (push sym macros))
+          ((and (fboundp sym)
+                (typep (fboundp sym) (find-class 'generic-function)))
+           (push sym generics))
+          ((fboundp sym)
+           (push sym functions)))
+        (cond
+          ((and (boundp sym)
+                (constantp sym))
+           (push sym constants))
+          ((boundp sym)
+           (push sym vars)))))
+    ;; Remove any generic functions that represent slot accessors
+    (setf generics
+          (set-difference generics
+                          (list-all-slot-accessors
+                           (mapcar #'find-class classes))))
+    (dolist (sym functions)
+      (document sym 'function))
+    (dolist (sym macros)
+      (document sym 'macro))
+    (dolist (sym generics)
+      (document sym 'generic))
+    (dolist (sym classes)
+      (document sym 'class))
+    (dolist (sym vars)
+      (document sym 'var))
+    (dolist (sym constants)
+      (document sym 'constant))))
+
+
+(defun docpkg (pkgname)
+  (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)))
+
+
+
+;;;; Test package =============================================================
+
+(defpackage :mypkg
+  (:use :cl :closer-mop)
+  (:shadowing-import-from :closer-mop
+                          #:standard-method
+                          #:standard-generic-function
+                          #:defmethod
+                          #:defgeneric
+                          #:standard-class))
+(in-package :mypkg)
+(defvar *foovar* 3 "A variable.")
+(defconstant +fooconst+ 44 "A constant.")
+(defun foofun (x y)
+  "A function."
+  (+ x y))
+(defclass <foo> ()
+  ((fooslot :initform 0 :accessor fooslot))
+  (:documentation "A class."))
+(defclass <foochild> (<foo>)
+  ((childslot :initform 1 :accessor childslot
+              :documentation "Child slot doc"))
+  (:documentation "A child class."))
+(defgeneric foomethod (a b)
+  (:documentation "A generic function."))
+(defmethod foomethod ((a integer) (b integer))
+  (- a b))
+(defmethod barmethod ((a integer) b &key (c nil))
+  (+ a b))
+(defmacro foomac (x)
+  "A macro."
+  `(+ ,x))
+(defstruct foostruct
+  "A structure."
+  x y)
+(make-instance '<foo>)
+(in-package :clod)
+