master 4f27d763bbe: Make 'vtable-insert-object' more versatile

[Eli Zaretskii]

branch: master
commit 4f27d763bbe3312b6039fa59f2874bd8e002d201
Author: Joost Kremers <joostkremers@fastmail.com>
Commit: Eli Zaretskii <eliz@gnu.org>

    Make 'vtable-insert-object' more versatile
    
    * lisp/emacs-lisp/vtable.el (vtable-insert-object): Rename
    argument AFTER-OBJECT to LOCATION; allow use of index to
    refer to the insertion position; add argument BEFORE.
    (Bug#70664).
    
    * etc/NEWS:
    * doc/misc/vtable.texi (Interface Functions): Document the
    change.
    
    * test/lisp/emacs-lisp/vtable-tests.el
    (test-vtable-insert-object): New test.
---
 doc/misc/vtable.texi                 | 18 +++++--
 etc/NEWS                             | 13 +++++
 lisp/emacs-lisp/vtable.el            | 98 +++++++++++++++++++++++++++---------
 test/lisp/emacs-lisp/vtable-tests.el | 30 +++++++++++
 4 files changed, 132 insertions(+), 27 deletions(-)

diff --git a/doc/misc/vtable.texi b/doc/misc/vtable.texi
index dd5b70cf32f..822b1097cd9 100644
--- a/doc/misc/vtable.texi
+++ b/doc/misc/vtable.texi
@@ -548,10 +548,20 @@ Remove @var{object} from @var{table}.  This also updates 
the displayed
 table.
 @end defun
 
-@defun vtable-insert-object table object &optional after-object
-Insert @var{object} into @var{table}.  If @var{after-object}, insert
-the object after this object; otherwise append to @var{table}.  This
-also updates the displayed table.
+@defun vtable-insert-object table object &optional location before
+Insert @var{object} into @var{table}.  @var{location} should be an
+object in the table, the new object is inserted after this object, or
+before it if @var{before} is non-nil.  If @var{location} is @code{nil},
+@var{object} is appended to @var{table}, or prepended if @var{before} is
+non-@code{nil}.
+
+@var{location} can also be an integer, a zero-based index into the
+table.  In this case, @var{object} is inserted at that index.  If the
+index is out of range, @var{object} is prepended to @var{table} if the
+index is too small, or appended if it is too large.  In this case,
+@var{before} is ignored.
+
+This also updates the displayed table.
 @end defun
 
 @defun vtable-update-object table object &optional old-object
diff --git a/etc/NEWS b/etc/NEWS
index 77b2749fe43..5bf9a2d07c8 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -2635,6 +2635,19 @@ this case, would mean repeating the object in the 
argument list.)  When
 replacing an object with a different one, passing both the new and old
 objects is still necessary.
 
+** 'vtable-insert-object' can insert "before" or at an index.
+The signature of 'vtable-insert-object' has changed and is now:
+
+(vtable-insert-object table object &optional location before)
+
+'location' corresponds to the old 'after-object' argument; if 'before'
+is non-nil, the new object is inserted before the 'location' object,
+making it possible to insert a new object at the top of the
+table. (Before, this was not possible.)  In addition, 'location' can be
+an integer, a (zero-based) index into the table at which the new object
+is inserted ('before' is ignored in this case).
+
+
 ** JSON
 
 ---
diff --git a/lisp/emacs-lisp/vtable.el b/lisp/emacs-lisp/vtable.el
index d8e5136c666..cb7ea397314 100644
--- a/lisp/emacs-lisp/vtable.el
+++ b/lisp/emacs-lisp/vtable.el
@@ -348,19 +348,57 @@ This will also remove the displayed line."
       (when (vtable-goto-object object)
         (delete-line)))))
 
-(defun vtable-insert-object (table object &optional after-object)
-  "Insert OBJECT into TABLE after AFTER-OBJECT.
-If AFTER-OBJECT is nil (or doesn't exist in the table), insert
-OBJECT at the end.
+;; FIXME: The fact that the `location' argument of
+;; `vtable-insert-object' can be an integer and is then interpreted as
+;; an index precludes the use of integers as objects.  This seems a very
+;; unlikely use-case, so let's just accept this limitation.
+
+(defun vtable-insert-object (table object &optional location before)
+  "Insert OBJECT into TABLE at LOCATION.
+LOCATION is an object in TABLE.  OBJECT is inserted after LOCATION,
+unless BEFORE is non-nil, in which case it is inserted before LOCATION.
+
+If LOCATION is nil, or does not exist in the table, OBJECT is inserted
+at the end of the table, or at the beginning if BEFORE is non-nil.
+
+LOCATION can also be an integer, a (zero-based) index into the table.
+OBJECT is inserted at this location.  If the index is out of range,
+OBJECT is inserted at the beginning (if the index is less than 0) or
+end (if the index is too large) of the table.  BEFORE is ignored in this
+case.
+
 This also updates the displayed table."
+  ;; FIXME: Inserting an object into an empty vtable currently isn't
+  ;; possible. `nconc' fails silently (twice), and `setcar' on the cache
+  ;; raises an error.
+  (if (null (vtable-objects table))
+      (error "[vtable] Cannot insert object into empty vtable"))
   ;; First insert into the objects.
-  (let (pos)
-    (if (and after-object
-             (setq pos (memq after-object (vtable-objects table))))
-        ;; Splice into list.
-        (setcdr pos (cons object (cdr pos)))
-      ;; Append.
-      (nconc (vtable-objects table) (list object))))
+  (let ((pos (if location
+                 (if (integerp location)
+                     (prog1
+                         (nthcdr location (vtable-objects table))
+                       ;; Do not prepend if index is too large:
+                       (setq before nil))
+                   (or (memq location (vtable-objects table))
+                       ;; Prepend if `location' is not found and
+                       ;; `before' is non-nil:
+                       (and before (vtable-objects table))))
+               ;; If `location' is nil and `before' is non-nil, we
+               ;; prepend the new object.
+               (if before (vtable-objects table)))))
+    (if (or before  ; If `before' is non-nil, `pos' should be, as well.
+            (and pos (integerp location)))
+        ;; Add the new object before.
+        (let ((old-object (car pos)))
+          (setcar pos object)
+          (setcdr pos (cons old-object (cdr pos))))
+      ;; Otherwise, add the object after.
+      (if pos
+          ;; Splice the object into the list.
+          (setcdr pos (cons object (cdr pos)))
+        ;; Otherwise, append the object.
+        (nconc (vtable-objects table) (list object)))))
   ;; Then adjust the cache and display.
   (save-excursion
     (vtable-goto-table table)
@@ -372,19 +410,33 @@ This also updates the displayed table."
                                      'face (vtable-face table))
                        ""))
            (ellipsis-width (string-pixel-width ellipsis))
-           (elem (and after-object
-                      (assq after-object (car cache))))
+           (elem (if location  ; This binding mirrors the binding of `pos' 
above.
+                     (if (integerp location)
+                         (nth location (car cache))
+                       (or (assq location (car cache))
+                           (and before (caar cache))))
+                   (if before (caar cache))))
+           (pos (memq elem (car cache)))
            (line (cons object (vtable--compute-cached-line table object))))
-      (if (not elem)
-          ;; Append.
-          (progn
-            (setcar cache (nconc (car cache) (list line)))
-            (vtable-end-of-table))
-        ;; Splice into list.
-        (let ((pos (memq elem (car cache))))
-          (setcdr pos (cons line (cdr pos)))
-          (unless (vtable-goto-object after-object)
-            (vtable-end-of-table))))
+      (if (or before
+              (and pos (integerp location)))
+          ;; Add the new object before:.
+          (let ((old-line (car pos)))
+            (setcar pos line)
+            (setcdr pos (cons old-line (cdr pos)))
+            (unless (vtable-goto-object (car elem))
+              (vtable-beginning-of-table)))
+        ;; Otherwise, add the object after.
+        (if pos
+            ;; Splice the object into the list.
+            (progn
+              (setcdr pos (cons line (cdr pos)))
+              (if (vtable-goto-object location)
+                  (forward-line 1)  ; Insert *after*.
+                (vtable-end-of-table)))
+          ;; Otherwise, append the object.
+          (setcar cache (nconc (car 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.
diff --git a/test/lisp/emacs-lisp/vtable-tests.el 
b/test/lisp/emacs-lisp/vtable-tests.el
index 08fdf1594a4..1d4b0650210 100644
--- a/test/lisp/emacs-lisp/vtable-tests.el
+++ b/test/lisp/emacs-lisp/vtable-tests.el
@@ -39,4 +39,34 @@
                          :insert nil)))
           '(left right left))))
 
+(ert-deftest test-vtable-insert-object ()
+  (should
+   (equal (let ((buffer (get-buffer-create " *vtable-test*")))
+            (pop-to-buffer buffer)
+            (erase-buffer)
+            (let* ((object1 '("Foo" 3))
+                   (object2 '("Gazonk" 8))
+                   (table (make-vtable
+                           :columns '("Name" (:name "Rank" :width 5))
+                           :objects (list object1 object2))))
+              (mapc (lambda (args)
+                      (pcase-let ((`(,object ,location ,before) args))
+                        (vtable-insert-object table object location before)))
+                    `( ; Some correct inputs.
+                      ;; object    location        before
+                      (("Fizz" 4)  ,object1        nil)
+                      (("Bop"  7)  ,object2        t)
+                      (("Zat"  5)  2               nil)
+                      (("Dib"  6)  3               t)
+                      (("Wup"  9)  nil             nil)
+                      (("Quam" 2)  nil             t)
+                      ;; And some faulty inputs.
+                      (("Yat"  1)  -1              nil) ; non-existing index, 
`before' is ignored.
+                      (("Vop"  10) 100             t)   ; non-existing index, 
`before' is ignored.
+                      (("Jib"  11) ("Bleh"  0)     nil) ; non-existing object.
+                      (("Nix"  0)  ("Ugh"   0)     t)   ; non-existing object.
+                      ))
+              (mapcar #'cadr (vtable-objects table))))
+          (number-sequence 0 11))))
+
 ;;; vtable-tests.el ends here