Package: emacs;
Reported by: Stéphane Marks <shipmints <at> gmail.com>
Date: Sun, 13 Jul 2025 18:08:01 UTC
Severity: normal
Tags: patch
Message #11 received at 79009 <at> debbugs.gnu.org (full text, mbox):
From: Spencer Baugh <sbaugh <at> janestreet.com> To: Stéphane Marks <shipmints <at> gmail.com> Cc: Kristoffer Balintona <krisbalintona <at> gmail.com>, Joost Kremers <joostkremers <at> fastmail.fm>, 79009 <at> debbugs.gnu.org, Visuwesh <visuweshm <at> gmail.com>, Adam Porter <adam <at> alphapapa.net>, Lars Ingebrigtsen <larsi <at> gnus.org>, Augusto Stoffel <arstoffel <at> gmail.com>, ijqq <at> protonmail.com Subject: Re: bug#79009: [PATCH] Improve 'vtable' object handling, cache handling, messages, [PATCH] Improve 'vtable' object handling, cache handling, messages Date: Mon, 14 Jul 2025 15:54:42 -0400
Stéphane Marks <shipmints <at> gmail.com> writes:
> On Sun, Jul 13, 2025 at 2:16 PM Stéphane Marks <shipmints <at> gmail.com> wrote:
> I've updated the broader vtable update in the referenced 78843 bug to check out if interested.
>
> I've removed support for the duplicate-object feature. After careful consideration, it was half baked and I think better for vtable
> programmers to handle their own objects. I will be sure the documentation stresses to avoid duplicate objects as vtable's design is
> predicated on unique objects (or race conditions ensue among duplicate object references).
Thank you, this was going to be my first bit of feedback.
Folowup question: What is the motivation for adding customizable object
equality? Could the need for that be avoided by some changes specific
to vtable-update-object?
> Attaching the updated patch which is also formatted to avoid mere whitespace changes.
Thanks for this too.
> From e7bb61becb15e07ebd3e54cf2c1ea2becada09b0 Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?St=C3=A9phane=20Marks?= <shipmints <at> gmail.com>
> Date: Sun, 13 Jul 2025 13:32:28 -0400
> Subject: [PATCH] Improve 'vtable' object handling, cache handling, messages
>
> Add object equality function override (defaults to existing 'eq'
> behavior). Add column comparator to address object
> sorting (defaults to existing behavior). Correct cache
> references to prime the cache as needed. Add cache accessor
> functions. Add table name slot to improve errors and
> messages (defaults to "*vtable*").
>
> Added tests.
>
> * lisp/emacs-lisp/vtable.el (vtable-column): Add comparator
> slot.
> (vtable): Add name, object-equal slots.
> (make-vtable): Initialize new slots.
> (vtable-goto-object): Use object-equal.
> (vtable-update-object): Use object-equal, use cache accessor,
> improve messages.
> (vtable-remove-object): Use object-equal, prime cache, use cache
> functions, improve messages.
> (vtable-insert-object): Use object-equal, use cache accessor,
> improve messages.
> (vtable-insert): Prime cache, use cache accessor.
> (vtable--sort): Use column comparator, prime cache, use cache
> accessor.
> (vtable--compute-width): Improve message.
> (vtable--widths): Use cache accessor.
>
> * test/lisp/emacs-lisp/vtable-tests.el
> (test-vstable-compute-columns): Renamed to
> test-vtable-compute-columns.
> (test-vtable-insert-object): Changed buffer name to non-hidden.
> (test-vtable-update-object, test-vtable-remove-object)
> (test-vtable-object-equal, test-vtable-column-comparator): New
> test.
> ---
> lisp/emacs-lisp/vtable.el | 143 ++++++++++++++++++++-------
> test/lisp/emacs-lisp/vtable-tests.el | 106 +++++++++++++++++++-
> 2 files changed, 210 insertions(+), 39 deletions(-)
>
> diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
> index 00785113edb..31ef73d5eb4 100644
> --- a/lisp/emacs-lisp/vtable.el
> +++ b/lisp/emacs-lisp/vtable.el
> @@ -45,14 +45,18 @@ vtable-column
> getter
> formatter
> displayer
> + comparator
> -numerical
> -aligned)
>
> (defclass vtable ()
> - ((columns :initarg :columns :accessor vtable-columns)
> + ((name :initarg :name :accessor vtable-name)
> + (columns :initarg :columns :accessor vtable-columns)
> (objects :initarg :objects :accessor vtable-objects)
> (objects-function :initarg :objects-function
> :accessor vtable-objects-function)
> + (object-equal :initarg :object-equal
> + :accessor vtable-object-equal)
(I feel like there's probably a better name for this but I don't know
what it would be)
> (getter :initarg :getter :accessor vtable-getter)
> (formatter :initarg :formatter :accessor vtable-formatter)
> (displayer :initarg :displayer :accessor vtable-displayer)
> @@ -86,7 +90,12 @@ vtable-header-line-map
> "<follow-link>" 'mouse-face
> "<mouse-2>" #'vtable-header-line-sort)
>
> -(cl-defun make-vtable (&key columns objects objects-function
> +(cl-defun make-vtable (&key
> + (name "*vtable*")
> + columns
> + objects
> + objects-function
> + (object-equal #'eq)
> getter
> formatter
> displayer
No need to reformat this.
> @@ -113,8 +122,10 @@ make-vtable
> (let ((table
> (make-instance
> 'vtable
> + :name name
> :objects objects
> :objects-function objects-function
> + :object-equal object-equal
> :getter getter
> :formatter formatter
> :displayer displayer
> @@ -132,7 +143,8 @@ make-vtable
> ;; Auto-generate the columns.
> (unless columns
> (unless objects
> - (error "Can't auto-generate columns; no objects"))
> + (error "Can't auto-generate columns; no objects (vtable `%s')"
> + (vtable-name table)))
> (setq columns (make-list (length (car objects)) "")))
> (setf (vtable-columns table)
> (mapcar (lambda (column)
> @@ -251,14 +263,15 @@ vtable-goto-object
> Return the position of the object if found, and nil if not."
> (let ((start (point)))
> (vtable-beginning-of-table)
> + (let ((predicate (vtable-object-equal (vtable-current-table))))
> (save-restriction
> (narrow-to-region (point) (save-excursion (vtable-end-of-table)))
> - (if (text-property-search-forward 'vtable-object object #'eq)
> + (if (text-property-search-forward 'vtable-object object predicate)
> (progn
> (forward-line -1)
> (point))
> (goto-char start)
> - nil))))
> + nil)))))
>
> (defun vtable-goto-table (table)
> "Go to TABLE in the current buffer.
> @@ -291,25 +304,32 @@ vtable-update-object
> (let* ((objects (vtable-objects table))
> (inhibit-read-only t))
> ;; First replace the object in the object storage.
> - (if (eq old-object (car objects))
> + (if (funcall (vtable-object-equal table) old-object (car objects))
> ;; It's at the head, so replace it there.
> (setf (vtable-objects table)
> (cons object (cdr objects)))
> ;; Otherwise splice into the list.
> (while (and (cdr objects)
> - (not (eq (cadr objects) old-object)))
> + (not (funcall (vtable-object-equal table)
> + (cadr objects) old-object)))
> (setq objects (cdr objects)))
> - (unless objects
> - (error "Can't find the old object"))
> + (unless (and objects
> + (funcall (vtable-object-equal table)
> + (cadr objects) old-object))
> + (error "Can't find the old object (vtable `%s')"
> + (vtable-name table)))
> (setcar (cdr objects) object))
> ;; Then update the cache...
> ;; FIXME: If the table's buffer has no visible window, or if its
> ;; width has changed since the table was updated, the cache key will
> ;; not match and the object can't be updated. (Bug #69837).
> - (if-let* ((line-number (seq-position (car (vtable--cache table)) old-object
> - (lambda (a b)
> - (equal (car a) b))))
> - (line (elt (car (vtable--cache table)) line-number)))
> + (if-let* ((cache (vtable--ensure-cache table))
> + (line-number (seq-position
> + (vtable--cache-lines cache)
> + (assoc old-object
> + (vtable--cache-lines cache)
> + (vtable-object-equal table))))
> + (line (elt (vtable--cache-lines cache) line-number)))
I think you should either remove the vtable--cache function entirely or
make vtable--cache do what vtable--ensure-cache does.
Better yet: adopt what I did in bug#69837, which mostly removes the code
which looks up the cache based on the current window and frame
attributes. Such code is not correct anyway, since when modifying part
of a vtable that already exists, one should use the widths which are
already in place for that vtable, as I mentioned in my patch there.
> (progn
> (setcar line object)
> (setcdr line (vtable--compute-cached-line table object))
> @@ -320,28 +340,46 @@ vtable-update-object
> (start (point)))
> (delete-line)
> (vtable--insert-line table line line-number
> - (nth 1 (vtable--cache table))
> + (vtable--cache-widths cache)
> (vtable--spacer table))
> (add-text-properties start (point) (list 'keymap keymap
> 'vtable table))))
> ;; We may have inserted a non-numerical value into a previously
> ;; all-numerical table, so recompute.
> (vtable--recompute-numerical table (cdr line)))
> - (error "Can't find cached object in vtable"))))
> + (error "Can't find cached object (vtable `%s')"
> + (vtable-name table)))))
>
> (defun vtable-remove-object (table object)
> "Remove OBJECT from TABLE.
> This will also remove the displayed line."
> + (let ((cache (vtable--ensure-cache table))
> + (inhibit-read-only t))
> + (unless (seq-contains-p (vtable-objects table)
> + object
> + (vtable-object-equal table))
> + (error "Can't find the object to remove (vtable `%s')"
> + (vtable-name table)))
> ;; First remove from the objects.
> - (setf (vtable-objects table) (delq object (vtable-objects table)))
> + (setf (vtable-objects table) (seq-remove
> + (lambda (elt)
> + (funcall (vtable-object-equal table)
> + elt object))
> + (vtable-objects table)))
> ;; Then adjust the cache and display.
> - (let ((cache (vtable--cache table))
> - (inhibit-read-only t))
> - (setcar cache (delq (assq object (car cache)) (car cache)))
> + (if-let* ((old-line (assoc object
> + (vtable--cache-lines cache)
> + (vtable-object-equal table))))
> + (progn
> + (setcar cache (delq old-line (vtable--cache-lines cache)))
> (save-excursion
> (vtable-goto-table table)
> (when (vtable-goto-object object)
> - (delete-line)))))
> + (delete-line))))
> + ;; At this point, the object was removed from objects, but not
> + ;; the cache, which will stale.
> + (error "Can't find cached object (vtable `%s')"
> + (vtable-name table)))))
So then why not look the object up in both the cache and objects first,
before modifying either?
Also, it seems like maybe vtable-remove-object should not actually be
using the customizable object equality anyway?
>
> ;; FIXME: The fact that the `location' argument of
> ;; `vtable-insert-object' can be an integer and is then interpreted as
> @@ -378,7 +416,16 @@ vtable-insert-object
> (nthcdr location (vtable-objects table))
> ;; Do not prepend if index is too large:
> (setq before nil))
> - (or (memq location (vtable-objects table))
> + (or
> + (let ((loc (vtable-objects table)))
> + (while (and (cdr loc)
> + (not (funcall (vtable-object-equal table)
> + (car loc) location)))
> + (setq loc (cdr loc)))
> + (if (funcall (vtable-object-equal table)
> + (car loc) location)
> + loc
> + nil))
I think you probably should introduce a function which searches
(vtable-objects table) for an existing object using the equality
function, and use that everywhere; it would make the changes like this
much simpler.
> ;; Prepend if `location' is not found and
> ;; `before' is non-nil:
> (and before (vtable-objects table))))
> @@ -400,7 +447,7 @@ vtable-insert-object
> ;; Then adjust the cache and display.
> (save-excursion
> (vtable-goto-table table)
> - (let* ((cache (vtable--cache table))
> + (let* ((cache (vtable--ensure-cache table))
> (inhibit-read-only t)
> (keymap (get-text-property (point) 'keymap))
> (ellipsis (if (vtable-ellipsis table)
> @@ -410,11 +457,14 @@ vtable-insert-object
> (ellipsis-width (string-pixel-width ellipsis))
> (elem (if location ; This binding mirrors the binding of `pos' above.
> (if (integerp location)
> - (nth location (car cache))
> - (or (assq location (car cache))
> + (nth location (vtable--cache-lines cache))
> + (or (assoc
> + location
> + (vtable--cache-lines cache)
> + (vtable-object-equal table))
> (and before (caar cache))))
> (if before (caar cache))))
> - (pos (memq elem (car cache)))
> + (pos (memq elem (vtable--cache-lines cache)))
> (line (cons object (vtable--compute-cached-line table object))))
> (if (or before
> (and pos (integerp location)))
> @@ -433,13 +483,14 @@ vtable-insert-object
> (forward-line 1) ; Insert *after*.
> (vtable-end-of-table)))
> ;; Otherwise, append the object.
> - (setcar cache (nconc (car cache) (list line)))
> + (setcar cache (nconc (vtable--cache-lines cache) (list line)))
> (vtable-end-of-table)))
> (let ((start (point)))
> ;; FIXME: We have to adjust colors in lines below this if we
> ;; have :row-colors.
> (vtable--insert-line table line 0
> - (nth 1 cache) (vtable--spacer table)
> + (vtable--cache-widths cache)
> + (vtable--spacer table)
> ellipsis ellipsis-width)
> (add-text-properties start (point) (list 'keymap keymap
> 'vtable table)))
> @@ -523,7 +574,8 @@ vtable--ensure-cache
> (vtable--recompute-cache table)))
>
> (defun vtable-insert (table)
> - (let* ((spacer (vtable--spacer table))
> + (let* ((cache (vtable--ensure-cache table))
> + (spacer (vtable--spacer table))
> (start (point))
> (ellipsis (if (vtable-ellipsis table)
> (propertize (truncate-string-ellipsis)
> @@ -533,7 +585,7 @@ vtable-insert
> ;; We maintain a cache per screen/window width, so that we render
> ;; correctly if Emacs is open on two different screens (or the
> ;; user resizes the frame).
> - (widths (nth 1 (vtable--ensure-cache table))))
> + (widths (vtable--cache-widths cache)))
> ;; Don't insert any header or header line if the user hasn't
> ;; specified the columns.
> (when (slot-value table '-has-column-spec)
> @@ -551,7 +603,7 @@ vtable-insert
> (vtable--sort table)
> ;; Insert the data.
> (let ((line-number 0))
> - (dolist (line (car (vtable--cache table)))
> + (dolist (line (vtable--cache-lines cache))
> (vtable--insert-line table line line-number widths spacer
> ellipsis ellipsis-width)
> (setq line-number (1+ line-number))))
> @@ -667,18 +719,26 @@ vtable--clear-cache
>
> (defun vtable--sort (table)
> (pcase-dolist (`(,index . ,direction) (vtable-sort-by table))
> - (let ((cache (vtable--cache table))
> - (numerical (vtable-column--numerical
> - (elt (vtable-columns table) index)))
> + (let* ((cache (vtable--ensure-cache table))
> + (column (elt (vtable-columns table) index))
> + (numerical (vtable-column--numerical column))
> (numcomp (if (eq direction 'descend)
> #'> #'<))
> (stringcomp (if (eq direction 'descend)
> - #'string> #'string<)))
> + #'string> #'string<))
> + (comparator (vtable-column-comparator column))
> + (comparator-func (when comparator
> + (if (eq direction 'descend)
> + (lambda (v1 v2)
> + (funcall comparator v2 v1))
> + comparator))))
> (setcar cache
> - (sort (car cache)
> + (sort (vtable--cache-lines cache)
> (lambda (e1 e2)
> (let ((c1 (elt e1 (1+ index)))
> (c2 (elt e2 (1+ index))))
> + (if comparator-func
> + (funcall comparator-func (car c1) (car c2))
> (if numerical
> (funcall numcomp (car c1) (car c2))
> (funcall
> @@ -688,7 +748,7 @@ vtable--sort
> (format "%s" (car c1)))
> (if (stringp (car c2))
> (car c2)
> - (format "%s" (car c2))))))))))))
> + (format "%s" (car c2)))))))))))))
>
> (defun vtable--indicator (table index)
> (let ((order (car (last (vtable-sort-by table)))))
> @@ -860,7 +920,8 @@ vtable--compute-width
> (/ (* (string-to-number (match-string 1 spec)) (window-width nil t))
> 100))
> (t
> - (error "Invalid spec: %s" spec))))
> + (error "Invalid spec: %s (vtable `%s')"
> + spec (vtable-name table)))))
>
> (defun vtable--compute-widths (table cache)
> "Compute the display widths for TABLE.
> @@ -972,7 +1033,13 @@ vtable-revert
> (vtable-goto-column column))))
>
> (defun vtable--widths (table)
> - (nth 1 (vtable--ensure-cache table)))
> + (vtable--cache-widths (vtable--ensure-cache table)))
> +
> +(defun vtable--cache-widths (cache)
> + (nth 1 cache))
> +
> +(defun vtable--cache-lines (cache)
> + (car cache))
> ;;; Commands.
>
> diff --git a/test/lisp/emacs-lisp/vtable-tests.el b/test/lisp/emacs-lisp/vtable-tests.el
> index 74fb8cc8139..6e3c09e14de 100644
> --- a/test/lisp/emacs-lisp/vtable-tests.el
> +++ b/test/lisp/emacs-lisp/vtable-tests.el
> @@ -27,7 +27,7 @@
> (require 'ert)
> (require 'ert-x)
>
> -(ert-deftest test-vstable-compute-columns ()
> +(ert-deftest test-vtable-compute-columns ()
> (should
> (equal (mapcar
> (lambda (column)
> @@ -69,4 +69,108 @@ test-vtable-insert-object
> (mapcar #'cadr (vtable-objects table))))
> (number-sequence 0 11))))
>
> +(ert-deftest test-vtable-update-object ()
> + (let ((buffer (get-buffer-create "*vtable-test*")))
> + (pop-to-buffer buffer)
> + (erase-buffer)
> + (let* ((object1 (cons "XXX" 1))
> + (object2 (cons "YYY" 2))
> + (table
> + (make-vtable
> + :use-header-line nil
> + :object-equal #'eq ; Identity.
> + :columns '((:name "XXX"))
> + :objects (list object1 object2))))
> + (should-error (vtable-update-object table "ZZZ"))
> + (setcdr object1 3)
> + (vtable-update-object table object1)
> + (should (eq 3 (cdr (assoc "XXX" (vtable-objects table))))))))
> +
> +(ert-deftest test-vtable-remove-object ()
> + (let ((buffer (get-buffer-create "*vtable-test*")))
> + (pop-to-buffer buffer)
> + (erase-buffer)
> + (let* ((object1 (cons "XXX" 1))
> + (object2 (cons "YYY" 2))
> + (table
> + (make-vtable
> + :use-header-line nil
> + :object-equal #'eq ; Identity.
> + :columns '((:name "XXX"))
> + :objects (list object1 object2))))
> + (should-error (vtable-remove-object table "ZZZ"))
> + (vtable-remove-object table object1)
> + (should (eq 1 (length (vtable-objects table)))))))
> +
> +(ert-deftest test-vtable-object-equal ()
> + (let ((buffer (get-buffer-create "*vtable-test*")))
> + (pop-to-buffer buffer)
> + (erase-buffer)
> + (let* ((object1 "XXX")
> + (object2 "XXX")
> + (table-eq
> + (progn
> + (goto-char (point-max))
> + (make-vtable
> + :use-header-line nil
> + :columns '((:name "table-eq" :width 20))
> + :object-equal #'eq ; Identity.
> + :objects (list object1 object2))))
> + (table-equal
> + (progn
> + (goto-char (point-max))
> + (make-vtable
> + :use-header-line nil
> + :columns '((:name "table-equal" :width 20))
> + :object-equal #'equal ; Value.
> + :objects (list object1 object2)))))
> + (should
> + (progn
> + (vtable-goto-table table-eq)
> + (vtable-goto-object object2)
> + (equal object2 (get-text-property (point) 'vtable-object))))
> + (should-not
> + (progn
> + (vtable-goto-table table-eq)
> + (vtable-goto-object "ZZZ")
> + (equal object1 (get-text-property (point) 'vtable-object))))
> + (should
> + (progn
> + (vtable-goto-table table-equal)
> + (vtable-goto-object object2)
> + (equal object1 (get-text-property (point) 'vtable-object))))
> + (should-not
> + (progn
> + (vtable-goto-table table-equal)
> + (vtable-goto-object "ZZZ")
> + (equal object1 (get-text-property (point) 'vtable-object)))))))
> +
> +(ert-deftest test-vtable-column-comparator ()
> + (let ((buffer (get-buffer-create "*vtable-test*")))
> + (pop-to-buffer buffer)
> + (erase-buffer)
> + (let ((table
> + (make-vtable
> + :use-header-line t
> + :getter (lambda (object _index _table) object)
> + :columns '(( :name "Date"
> + :primary ascend
> + :width 40
> + :formatter (lambda (object)
> + (let ((time (date-to-time object)))
> + (format "%s (%d)"
> + (format-time-string "%A, %B %d %Y" time)
> + (car time))))
> + :comparator (lambda (object1 object2)
> + (let ((time1 (date-to-time object1))
> + (time2 (date-to-time object2)))
> + (< (car time1)
> + (car time2))))))
> + :objects '("Fri, 11 Jul 2025"
> + "Thu, 10 Jul 2025"))))
> + (should
> + (string=
> + "Thursday"
> + (thing-at-point 'word))))))
> +
> ;;; vtable-tests.el ends here
Thank you very much for adding tests.
Overall this patch looks good, I am in favor of this landing soon (after
feedback is addressed of course).
(One other thing: Could you try to tell your mail client to attach the
patch in "inline" mode? This makes the patch somewhat easier to review
in debbugs. (This may be easiest if you use Gnus to send the patch,
perhaps using debbugs-gnu-post-patch))
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.