From c48ecda020797fe3fe65d55d02a8b72f6e7f19cb Mon Sep 17 00:00:00 2001
From: Colin Okay <okay@toyful.space>
Date: Thu, 17 Feb 2022 09:27:40 -0600
Subject: add whole classes to documentation

---
 lazybones.lisp | 39 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)

(limited to 'lazybones.lisp')

diff --git a/lazybones.lisp b/lazybones.lisp
index 66192a2..80d7f73 100644
--- a/lazybones.lisp
+++ b/lazybones.lisp
@@ -400,3 +400,42 @@ making a new one if not."
   "Remove definition keyed by LINK-TARGET from APP."
   (remhash name (app-definitions app)))
 
+(defun names-equal-p (s1 s2)
+  (or (equalp s1 s2)
+      (and (symbolp s1) (equalp (symbol-name s1) s2))
+      (and (symbolp s2) (equalp s1 (symbol-name s2)))
+      (and (symbolp s1) (symbolp s2)
+           (string-equal (symbol-name s1) (symbol-name s2)))))
+
+(defun getplist (indicator plist &key (test 'names-equal-p ) key)
+  (let ((indicator (if key (funcall key indicator) indicator))) 
+    (loop for (k0 v . more) on plist by #'cddr
+          for k = (if key (funcall key k0) k0)
+          when (funcall test indicator k)
+            return (values v t)
+          finally (return (values nil least-negative-long-float )))))
+
+(defun class-docs (class-name)
+  (closer-mop:ensure-finalized (find-class class-name))
+  (loop for plist in (trivial-documentation:symbol-definitions class-name)
+        when (eql :class (getf plist :kind))
+          return (list (getf plist :documentation)
+                       (getf plist :slots))))
+
+(defun add-class-to-definitions (app class-name &rest slot-names)
+  "Generates a definition entry from class and slot documentation
+CLASS-NAME should be a symbol, and SLOT-NAMES symbols."
+  (destructuring-bind (documentation slots) (class-docs class-name)
+    (set-definition (string-downcase (symbol-name class-name))
+                    (string-downcase (format nil "#~a" class-name))
+                    (with-output-to-string (*standard-output*)
+                      (princ documentation) 
+                      (princ #\newline) (princ #\newline)
+                      (princ "**Slots:**") (princ #\newline)
+                      (dolist (sn slot-names)
+                        (a:when-let (slot-doc (getplist sn slots))
+                          (princ "- ") (princ sn) (princ ": ")
+                          (princ slot-doc)
+                          (princ #\newline)))
+                      (princ #\newline))
+                    app)))
-- 
cgit v1.2.3