Fix autodoc support for slot writers

40ants-doc-test.asd

@@ -4,7 +4,10 @@
   :description "Test system for 40ANTS-DOC system."
   :class :package-inferred-system
   :pathname "test"
-  :depends-on ("40ants-doc-test/test-transcribe"
+  :depends-on ("40ants-doc/autodoc"
+               "40ants-doc-full"
+               "40ants-doc-test/test-transcribe"
+               "40ants-doc-test/autodoc"
                "40ants-doc-test/test"
                "40ants-doc-test/xref"
                "40ants-doc-test/locatives"

full/locatives/slots.lisp

@@ -87,7 +87,9 @@
 
 (defun find-writer-slot-definition (accessor-symbol class-symbol)
   (dolist (slot-def (swank-mop:class-direct-slots (find-class class-symbol)))
-    (when (find accessor-symbol (swank-mop:slot-definition-writers slot-def))
+    (when (find accessor-symbol (swank-mop:slot-definition-writers slot-def)
+                :key (lambda (w)
+                       (if (listp w) (second w) w)))
       (return-from find-writer-slot-definition slot-def)))
   (locate-error "Could not find writer ~S for class ~S." accessor-symbol
                 class-symbol))

src/autodoc.lisp

@@ -24,23 +24,41 @@
   (:documentation "This module is not included into asd file because it requires additional dependencies."))
 (in-package #:40ants-doc/autodoc)
 
-
-(defun class-readers-and-accessors (class-name &key (ignore-symbol-p 'starts-with-percent-p))
-  (let* ((class (find-class class-name))
-         (slots (class-direct-slots class)))
-    (loop for slot in slots
-          for readers = (remove-if ignore-symbol-p
-                                   (slot-definition-readers slot))
-          for writers = (remove-if ignore-symbol-p
-                                   (mapcar #'second
-                                           (slot-definition-writers slot)))
-          append readers into all-readers
-          append writers into all-writers
-          finally (return (values (sort all-readers
-                                        #'string<)
-                                  (sort all-writers
-                                        #'string<))))))
-
+(defmacro %flatmap-slots ((class-name slot-var) &body body)
+  "runs `body` on each slot (bound to `slot-var`) in `class-name`  body should
+return a list.  The results from all slots are flattened, sorted, and returned.
+
+This is meant for use with the class-readers and class-writers functions."
+  (let ((mapped-vals (gensym)))
+    `(loop :for ,slot-var :in (class-direct-slots (find-class ,class-name))
+           :append (progn ,@body) :into ,mapped-vals
+           :finally (return (sort ,mapped-vals #'string<)))))
+
+(defun class-readers (class-name &key (ignore-symbol-p 'starts-with-percent-p))
+  "returns list of methods that can read slots of `class-name`"
+  (%flatmap-slots (class-name slot)
+    (remove-if ignore-symbol-p (slot-definition-readers slot))))
+
+(defun class-writers (class-name &key (ignore-symbol-p 'starts-with-percent-p))
+  "returns list of methods that can write to slots of `class-name`."
+  (%flatmap-slots (class-name slot)
+    (remove-if ignore-symbol-p
+               (mapcar (lambda (writer)
+                         (if (typep writer 'list)
+                             (second writer)
+                             writer))
+                       (slot-definition-writers slot)))))
+
+(defun class-accessors (class-name &key (ignore-symbol-p 'starts-with-percent-p))
+  "returns list of methods that are accessors (ie can read and write) to slots
+of `class-name`."
+  (nintersection (class-readers class-name :ignore-symbol-p ignore-symbol-p)
+                 (class-writers class-name :ignore-symbol-p ignore-symbol-p)))
+
+(defun class-readers-writers (class-name &key (ignore-symbol-p 'starts-with-percent-p))
+  "returns list of all methods that read or write to slots of `class-name`"
+  (nunion (class-readers class-name :ignore-symbol-p ignore-symbol-p)
+          (class-writers class-name :ignore-symbol-p ignore-symbol-p)))
 
 (defun system-packages (system-name)
   (loop for package in (list-all-packages)
@@ -54,16 +72,13 @@
                               :key #'package-name))))
 
 
-(defun package-accessors-and-writers (package &key (ignore-symbol-p 'starts-with-percent-p))
+(defun package-readers-and-writers (package &key (ignore-symbol-p 'starts-with-percent-p))
   (loop with result = nil
         for symbol being the external-symbols of package
         when (find-class symbol nil)
-          do (multiple-value-bind (readers accessors)
-                 (class-readers-and-accessors symbol
-                                              :ignore-symbol-p ignore-symbol-p)
-               (setf result
-                     (nunion result
-                             (nunion readers accessors))))
+        do (setf result 
+                 (nunion result (class-readers-writers symbol
+                                                       :ignore-symbol-p ignore-symbol-p)))
         finally (return result)))
 
 
@@ -87,10 +102,15 @@
 (defun make-class-entry (class-name package-name &key (ignore-symbol-p 'starts-with-percent-p))
   (check-type class-name symbol)
   (check-type package-name string)
-
-  (multiple-value-bind (readers accessors)
-      (class-readers-and-accessors class-name
-                                   :ignore-symbol-p ignore-symbol-p)
+
+  (let ((all-readers (class-readers class-name :ignore-symbol-p ignore-symbol-p))
+        readers
+        (all-writers (class-writers class-name :ignore-symbol-p ignore-symbol-p))
+        writers
+        (accessors (class-accessors class-name :ignore-symbol-p ignore-symbol-p)))
+
+    (setf readers (set-difference all-readers all-writers)
+          writers (set-difference all-writers all-readers))
 
     (let* ((title (symbol-name class-name))
            (section-name (symbolicate
@@ -102,14 +122,21 @@
                           "?CLASS"))
            (entries
              (nconc
+              (when accessors
+                (list "**Accessors**"))
+              (loop for accessor in accessors
+                    collect `(,accessor (accessor ,class-name)))
+
               (when readers
                 (list "**Readers**"))
               (loop for reader in readers
                     collect `(,reader (reader ,class-name)))
-              (when accessors
-                (list "**Accessors**"))
-              (loop for accessor in accessors
-                    collect `(,accessor (accessor ,class-name)))))
+
+              (when writers
+                (list "**Writers**"))
+              (loop for writer in writers
+                    collect `(,writer (writer ,class-name)))))
+
            (section-definition
              `(eval-when (:compile-toplevel :load-toplevel :execute)
                 (defsection ,section-name (:title ,title
@@ -130,8 +157,9 @@
 
     (let* ((package-name (package-name package))
            (title package-name)
-           (accessors-and-readers (package-accessors-and-writers package
-                                                                 :ignore-symbol-p #'ignore-symbol-p-wrapper))
+           (readers-and-writers (package-readers-and-writers 
+                                 package
+                                 :ignore-symbol-p #'ignore-symbol-p-wrapper))
            (entries (loop for symbol being the external-symbols of package
                           for should-be-documented = (not (ignore-symbol-p-wrapper symbol))
                           ;; Usual functions
@@ -145,7 +173,7 @@
                           when (and (fboundp symbol)
                                     should-be-documented
                                     (typep (symbol-function symbol) 'generic-function)
-                                    (not (member symbol accessors-and-readers
+                                    (not (member symbol readers-and-writers
                                                  :test 'eql)))
                             collect (list symbol 'generic-function) into generics
 

src/changelog.lisp

@@ -155,6 +155,8 @@
                               "CLEAN-URLS"
                               ;; These objects are not documented yet:
                               "40ANTS-DOC/COMMONDOC/XREF:XREF"))
+  (0.26.1 2026-09-03
+          "* Fixed autodoc support for slots declared with `:writer`.")
   (0.26.0 2026-04-11
           "* Supported documentation building for projects cloned as git submodules.
            * Fixed external dependencies listing in case if some deps use :require.")
@@ -400,4 +402,3 @@
     - Allowed to reference objects using keywords.
     - Fixed docstring extraction for compiler macro."))
 
-

test/autodoc.lisp

@@ -0,0 +1,60 @@
+(uiop:define-package #:40ants-doc-test/autodoc
+  (:use #:cl)
+  (:import-from #:40ants-doc/autodoc
+                #:defautodoc)
+  (:import-from #:40ants-doc-full/locatives/slots)
+  (:import-from #:rove
+                #:deftest
+                #:ok
+                #:testing))
+(in-package #:40ants-doc-test/autodoc)
+
+
+(defclass slot-reader-writer-class ()
+  ((accessor-slot :accessor slot-accessor)
+   (reader-slot :reader slot-reader)
+   (writer-slot :writer slot-writer)))
+
+
+(deftest test-autodoc-classifies-slot-readers-writers-and-accessors
+  (testing "A class with all slot interface kinds is classified correctly"
+    (ok (equal (40ants-doc/autodoc::class-readers
+                'slot-reader-writer-class)
+               '(slot-accessor
+                 slot-reader)))
+    (ok (equal (40ants-doc/autodoc::class-writers
+                'slot-reader-writer-class)
+               '(slot-accessor
+                 slot-writer)))
+    (ok (equal (40ants-doc/autodoc::class-accessors
+                'slot-reader-writer-class)
+               '(slot-accessor)))
+    (let ((readers-and-writers
+            (40ants-doc/autodoc::class-readers-writers
+             'slot-reader-writer-class)))
+      (ok (= 3 (length readers-and-writers)))
+      (ok (subsetp '(slot-accessor
+                     slot-reader
+                     slot-writer)
+                   readers-and-writers)))))
+
+
+(deftest test-writer-locative-finds-a-writer-symbol
+  (testing "A writer locative resolves a slot declared with :writer"
+    (ok (40ants-doc-full/locatives/slots::find-writer-slot-definition
+         'slot-writer
+         'slot-reader-writer-class))))
+
+
+(deftest test-reader-locative-finds-a-reader-symbol
+  (testing "A reader locative resolves a slot declared with :reader"
+    (ok (40ants-doc-full/locatives/slots::find-reader-slot-definition
+         'slot-reader
+         'slot-reader-writer-class))))
+
+
+(deftest test-accessor-locative-finds-an-accessor-symbol
+  (testing "An accessor locative resolves a slot declared with :accessor"
+    (ok (40ants-doc-full/locatives/slots::find-accessor-slot-definition
+         'slot-accessor
+         'slot-reader-writer-class))))