doc/: start generating API documentation from docstrings

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

6 files changed, 182 insertions, 29 deletions

diff --git a/src/package.lisp b/src/package.lisp
index 6b72a1b..157bcfb 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -16,6 +16,7 @@
                           #:slurp-stream-string
                           #:subprocess-error
                           #:stripln
+                          #:println
                           #:unix-namestring
                           #:parse-unix-namestring
                           #:pathname-directory-pathname
@@ -58,6 +59,7 @@
            #:slurp-stream-string
            #:subprocess-error
            #:stripln
+           #:println
            #:unix-namestring
            #:parse-unix-namestring
            #:pathname-directory-pathname
diff --git a/src/property.lisp b/src/property.lisp
index 3aebe75..968b205 100644
--- a/src/property.lisp
+++ b/src/property.lisp
@@ -203,6 +203,152 @@
       (when indent
         (setf (get sym 'indent) indent)))))
 
+(defun docstring-to-rst (docstring)
+  ;; Unsurprisingly this gets a lot of cases wrong, so turned off for now.
+  ;; The block capitals already make them easy to pick out.
+  ;; (setq docstring
+  ;;       (re:regex-replace-all #?/(?<!\S)[A-Z:]*[A-Z]+[A-Z:-]*(?!\w)/
+  ;;                             docstring "``\\&``"))
+
+  ;; Format indented code examples for rST.
+  (do* ((lines (lines docstring) (cdr lines))
+        (line (car lines) (car lines))
+        indented accum)
+       ((null lines)
+        (stripln (unlines (nreverse accum))))
+    (acond
+      ((and (or indented (and accum (zerop (length (car accum)))))
+            (strip-prefix "    " line))
+       (unless indented
+         (unless (string= "" (car accum))
+           (push "" accum))
+         (push (if (or (char= #\( (first-char line))
+                       (string-prefix-p "'(" line))
+                   "::" ".. code-block:: none")
+               accum)
+         (push "" accum)
+         (setq indented t))
+       (push (strcat "  " it) accum))
+      ((and indented (zerop (length line))
+            (string-prefix-p "    " (cadr lines)))
+       (push "  " accum))
+      (t (push line accum)
+         (setq indented nil)))))
+
+(defparameter *defining-form-info-alist*
+  (flet ((docgetf (l) (getf l :documentation))
+         (docassoc (l) (cadr (assoc :documentation l)))
+         (numbers-to-functions (field)
+           (cond ((and (numberp field) (zerop field))
+                  (constantly nil))
+                 ((numberp field)
+                  (lambda (form)
+                    (values (nth field form) t)))
+                 ((functionp field)
+                  (lambda (form)
+                    (values (funcall field form) t)))
+                 (t field))))
+    (mapcar
+     (lambda (entry) (mapcar #'numbers-to-functions entry))
+     `((define-constant  "Constant"         0 ,(compose #'docgetf  #'cdddr))
+       (defgeneric       "Generic function" 2 ,(compose #'docassoc #'cdddr))
+       (defclass         "Class"            0 ,(compose #'docassoc #'cddddr))
+       (define-condition "Condition class"  0 ,(compose #'docassoc #'cddddr))
+
+       (defvar                              "Variable"             0 3)
+       (defparameter                        "Variable"             0 3)
+       (defun                               "Function"             2 3)
+       (defmacro                            "Macro"                2 3)
+       (defprop                             "Property"             3 4)
+       (defpropspec                         "Property"             3 4)
+       (defproplist                         "Property"             3 4)
+       (define-simple-error                 "Simple error"         4 3)
+       (define-function-property-combinator "Fn. prop. combinator" 2 3)))))
+
+(defun build-manual-rst
+    (target-rst &aux (target-rst
+                      (ensure-directories-exist
+                       (ensure-pathname target-rst
+                                        :want-file t :want-relative t)))
+                  (input-rst (make-pathname :type "rst.in"
+                                            :defaults target-rst))
+                  (input-lisp
+                   (make-pathname :type "lisp"
+                                  :defaults (merge-pathnames target-rst
+                                                             #P"../src/"))))
+  "Write TARGET-RST manual page based on input .rst.in and .lisp files."
+  (with-safe-io-syntax ()
+    (with-open-file (*standard-input* input-lisp :if-does-not-exist :error)
+      (with-open-file (*standard-output* target-rst :direction :output
+                                                    :if-exists :supersede)
+        (let* ((first-form (read))
+               (second-form (read))
+               (package (if (eql (car first-form) 'in-package)
+                            (find-package (cadr first-form))
+                            (error "First form of ~S is not IN-PACKAGE."
+                                   input-lisp)))
+               (package-exts (aprog1 (make-hash-table :test #'eq)
+                               (do-external-symbols (s package)
+                                 (setf (gethash s it) t))))
+               (input-rst-p (file-exists-p input-rst))
+               ;; We cannot have an anonymous first subsection of the API
+               ;; reference with Sphinx.
+               (section-heading "General"))
+          (labels ((println-heading (heading char)
+                     (loop initially (println heading)
+                           repeat (length heading) do (write-char char)
+                           finally (terpri)))
+                   (println-entry
+                       (form &aux
+                             (type (and (gethash (cadr form) package-exts)
+                                        (assoc (car form)
+                                               *defining-form-info-alist*)))
+                             (name (and type (abbreviate-consfigurator-package
+                                              (cadr form)))))
+                     (when type
+                       (when section-heading
+                         (terpri)
+                         (println-heading section-heading #\~)
+                         (setq section-heading nil))
+                       (terpri)
+                       (println-heading (format nil "~A: ``~A``"
+                                                (cadr type) name)
+                                        #\^)
+                       (multiple-value-bind (params paramsp)
+                           (funcall (caddr type) form)
+                         (when paramsp
+                           (format t "~%``~((~A~{ ~A~})~)``~&"
+                                   name
+                                   (mapcar #'ensure-car
+                                           (ldiff params
+                                                  (member '&aux params))))))
+                       (when-let ((docstring (funcall (cadddr type) form)))
+                         (when (stringp docstring)
+                           (terpri)
+                           (println (docstring-to-rst docstring)))))))
+            (unless (equal second-form
+                           '(named-readtables:in-readtable :consfigurator))
+              (error "Second form of ~S is not our IN-READTABLE." input-lisp))
+            (if input-rst-p
+                (with-open-file (input input-rst)
+                  (copy-stream-to-stream input *standard-output*)
+                  (terpri))
+                (println-heading (format nil "``~A``" (package-name package))
+                                 #\=))
+            (println-heading "API reference" #\-)
+            (let ((*package* package)
+                  (*readtable* (named-readtables:find-readtable
+                                :consfigurator.without-read-eval)))
+              (loop (handler-case
+                        ;; Read a line or a form depending on what's next.
+                        (if (char= #\( (peek-char t))
+                            (println-entry (read))
+                            ;; Don't print section heading yet in case it
+                            ;; doesn't contain any defns for exported symbols.
+                            (awhen (strip-prefix ";;;; " (read-line))
+                              (setq section-heading it)))
+                      (end-of-file () (return)))))))))))
+
 (defmacro with-*host*-*consfig* (&body forms)
   `(progv `(,(intern "*CONSFIG*"))
        `(,(propspec-systems (host-propspec *host*)))
@@ -632,11 +778,11 @@ PATH if PATH already has the specified CONTENT and MODE."
 
 (defmacro with-change-if-changes-file ((file) &body forms)
   "Execute FORMS and yield :NO-CHANGE if FILE does not change.
-Since stat(1) is not POSIX, this is implemented by calling `ls -dlL' and
+Since stat(1) is not POSIX, this is implemented by calling ``ls -dlL`` and
 cksum(1), and seeing if any of the information reported there, except for the
 number of links, has changed.  Thus, you should not use this macro to detect
-changes in properties which will change the file but not the output of `ls
--dlL' and cksum(1)."
+changes in properties which will change the file but not the output of
+``ls -dlL`` and cksum(1)."
   (with-gensyms (before)
     `(let* ((,before (ls-cksum ,file))
             (result (progn ,@forms)))
diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp
index 3e790d3..068c86b 100644
--- a/src/property/chroot.lisp
+++ b/src/property/chroot.lisp
@@ -100,7 +100,7 @@
                              ,(propspec-props propspec))))))
 
 (defproplist deploys :lisp (root host &optional additional-properties)
-  "Like DEPLOYS with first argument `((:chroot :into ,root)), but disable
+  "Like DEPLOYS with first argument ```((:chroot :into ,root))``, but disable
 starting services in the chroot, and set up access to parent hostattrs."
   (:desc #?"Subdeployment of ${root}")
   (consfigurator:deploys
@@ -108,8 +108,9 @@ starting services in the chroot, and set up access to parent hostattrs."
    (%make-child-host (union-propspec-into-host host additional-properties))))
 
 (defproplist deploys-these :lisp (root host properties)
-  "Like DEPLOYS-THESE with first argument `((:chroot :into ,root)), but disable
-starting services in the chroot, and set up access to parent hostattrs."
+  "Like DEPLOYS-THESE with first argument ```((:chroot :into ,root))``, but
+disable starting services in the chroot, and set up access to parent
+hostattrs."
   (:desc #?"Subdeployment of ${root}")
   (consfigurator:deploys
    `((:chroot :into ,root))
diff --git a/src/property/cron.lisp b/src/property/cron.lisp
index f60ecb8..2a3e7fe 100644
--- a/src/property/cron.lisp
+++ b/src/property/cron.lisp
@@ -21,10 +21,10 @@
 ;;; A number of techniques here are from Propellor's Cron properties module.
 
 (defpropspec system-job :posix (desc when user shell-command)
-  "Installs a cronjob running SHELL-COMMAND as USER to /etc/cron.*.
+  "Installs a cronjob running SHELL-COMMAND as USER to ``/etc/cron.*``.
 DESC must be unique, as it will be used as a filename for a script.  WHEN is
 either :DAILY, WEEKLY, :MONTHLY or a string formatted according to crontab(5),
-e.g. \"0 3 * * *\".
+e.g. ``0 3 * * *``.
 
 The output of the cronjob will be mailed only if the job exits nonzero."
   (:desc #?"Cronned ${desc}")
diff --git a/src/property/disk.lisp b/src/property/disk.lisp
index 4c650f9..f7b7b3d 100644
--- a/src/property/disk.lisp
+++ b/src/property/disk.lisp
@@ -998,7 +998,7 @@ filesystems will be incrementally updated when other properties change."
     (options host device-file &key chroot)
   "Install HOST to the DISK:PHYSICAL-DISK accessible at DEVICE-FILE.
 **THIS PROPERTY UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA,
-  EACH TIME IT IS APPLIED.**
+EACH TIME IT IS APPLIED.**
 
 Do not apply in DEFHOST.  Apply with DEPLOY-THESE/HOSTDEPLOY-THESE.
 
@@ -1046,7 +1046,7 @@ the host's actual physical disk upon first boot."
 (defpropspec volumes-installed-for :lisp (options host &key chroot leave-open)
   "Install HOST to its volumes, as specified using DISK:HAS-VOLUMES.
 **THIS PROPERTY UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA,
-  EACH TIME IT IS APPLIED.**
+EACH TIME IT IS APPLIED.**
 
 Do not apply in DEFHOST.  Apply with DEPLOY-THESE/HOSTDEPLOY-THESE.
 
@@ -1233,28 +1233,28 @@ specifications.  This becomes the VOLUME-CONTENTS of the VOLUME.
 
 The following keys in INITARGS are handled specially:
 
-    - :VOLUME-SIZE -- may be a string like \"100M\", \"2G\", \"1T\" which will
-      be converted into a whole number of mebibytes.  \"M\", \"G\", and \"T\"
-      are currently supported.
+  - :VOLUME-SIZE -- may be a string like \"100M\", \"2G\", \"1T\" which will
+    be converted into a whole number of mebibytes.  \"M\", \"G\", and \"T\"
+    are currently supported.
 
 Example usage:
 
-  (volumes
-    (physical-disk
-     (partitioned-volume
-      ((partition
-        :partition-typecode #xef00
-        (fat32-filesystem
-         :volume-size \"512M\"
-         :mount-point #P\"/boot/efi\"))
-       (partition
-        (luks-container
-         (lvm-physical-volume
-          :volume-group \"vg_laptop\"))))))
-    (lvm-logical-volume
-       :volume-group \"vg_laptop\"
-       :volume-label \"lv_laptop_root\"
-       (ext4-filesystem :mount-point #P\"/\")))"
+    (volumes
+      (physical-disk
+       (partitioned-volume
+        ((partition
+          :partition-typecode #xef00
+          (fat32-filesystem
+           :volume-size \"512M\"
+           :mount-point #P\"/boot/efi\"))
+         (partition
+          (luks-container
+           (lvm-physical-volume
+            :volume-group \"vg_laptop\"))))))
+      (lvm-logical-volume
+         :volume-group \"vg_laptop\"
+         :volume-label \"lv_laptop_root\"
+         (ext4-filesystem :mount-point #P\"/\")))"
   (labels
       ((parse (spec)
          (unless (listp spec)
diff --git a/src/reader.lisp b/src/reader.lisp
index 39314be..240750b 100644
--- a/src/reader.lisp
+++ b/src/reader.lisp
@@ -21,3 +21,7 @@
   (:merge :standard)
   (:dispatch-macro-char #\# #\? #'cl-interpol:interpol-reader)
   (:dispatch-macro-char #\# #\> #'cl-heredoc:read-heredoc))
+
+(named-readtables:defreadtable :consfigurator.without-read-eval
+  (:merge :consfigurator)
+  (:dispatch-macro-char #\# #\. (constantly nil)))