Skip to content

fixed autodoc detection of slot reader/writers #67

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
ethanxxxl wants to merge 1 commit into
base: master
Choose a base branch
from
Open

fixed autodoc detection of slot reader/writers #67

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 3 additions & 1 deletion full/locatives/slots.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down
98 changes: 63 additions & 35 deletions src/autodoc.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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)))


Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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

Expand Down