Merge branch 'master' of github.com:cbeo/lazybones

1 files changed, 39 insertions, 0 deletions

diff --git a/lazybones.lisp b/lazybones.lisp
index de2aeba..e23037f 100644
--- a/lazybones.lisp
+++ b/lazybones.lisp
@@ -402,3 +402,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)))