scratch/undo-apply 9b4f46a5108 1/3: Improve undo-in-region for 'apply entries

branch: scratch/undo-apply
commit 9b4f46a5108ef05f1c8b9b93a49856137b118f70
Author: Helmut Eller <[email protected]>
Commit: Helmut Eller <[email protected]>

    Improve undo-in-region for 'apply entries
    
    This patch adds a new variant of 'apply entries for the undo list of the
    form: (apply DELTA (BEG . END) FUN-NAME . ARGS).
    
    This similar to the existing (apply DELTA BEG END FUN-NAME . ARGS)
    variant.  The difference for the new variant is that FUN-NAME is applied
    to the adjusted BEG and END arguments together with ARGS.  This allows
    functions to compute positions relative to the adjusted region.
    
    The existing 'apply entry variants remain supported for backward
    compatibilty.
    
    * lisp/simple.el (primitive-undo): Call the function for the new 'apply
    variant with START and END.
    (undo-elt-in-region, undo-adjust-elt, undo-delta): Add support for the
    new 'apply entries.
    * test/src/undo-tests.el (undo-tests-selective-apply-1)
    (undo-tests-selective-apply-2): New tests.
    (undo-tests--mark-region, undo-tests--selective-apply)
    (undo-tests--undo-delete, undo-tests--undo-insert)
    (undo-tests--adjust-markers): New helpers.
---
 lisp/simple.el         | 79 +++++++++++++++++++++++++++++++++++------------
 test/src/undo-tests.el | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 143 insertions(+), 20 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index 1f7d57f299a..da3fdd71147 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3703,23 +3703,39 @@ Return what remains of the list."
            (delete-region beg end))
           ;; Element (apply FUN . ARGS) means call FUN to undo.
           (`(apply . ,fun-args)
-           (let ((currbuff (current-buffer)))
-             (if (integerp (car fun-args))
-                 ;; Long format: (apply DELTA START END FUN . ARGS).
-                 (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
-                              (start-mark (copy-marker start nil))
-                              (end-mark (copy-marker end t)))
-                   (when (or (> (point-min) start) (< (point-max) end))
-                     (error "Changes to be undone are outside visible portion of buffer"))
-                   (apply fun args) ;; Use `save-current-buffer'?
-                   ;; Check that the function did what the entry
-                   ;; said it would do.
-                   (unless (and (= start start-mark)
-                                (= (+ delta end) end-mark))
-                     (error "Changes undone by function are different from the announced ones"))
-                   (set-marker start-mark nil)
-                   (set-marker end-mark nil))
-               (apply fun-args))
+           (pcase-let* ((`(,delta ,start ,end ,fun . ,args)
+                         (pcase-exhaustive fun-args
+                           ((and `(,delta (,start . ,end) ,fun . ,args)
+                                 (guard (and (integerp delta)
+                                             (natnump start)
+                                             (natnump end)
+                                             (symbolp fun))
+                                        (guard (symbolp fun))))
+                            (cl-list* delta start end fun start end args))
+                           ((and `(,delta ,start ,end ,fun . ,_args)
+                                 (guard (and (integerp delta)
+                                             (natnump start)
+                                             (natnump end)
+                                             (symbolp fun))))
+                            fun-args)
+                           ((and `(,fun . ,args)
+                                 (guard (symbolp fun)))
+                            (cl-list* nil 1 (buffer-size) fun args))))
+                        (currbuff (current-buffer))
+                        (start-mark (copy-marker start nil))
+                        (end-mark (copy-marker end t)))
+             (when (and delta
+                        (or (< start (point-min)) (< (point-max) end)))
+               (error "Changes to be undone are outside visible\
+ portion of buffer"))
+             (apply fun args)
+             (when (and delta
+                        (or (/= start start-mark)
+                            (/= (+ delta end) end-mark)))
+               (error "Changes undone by function are different\
+ from the announced ones"))
+             (set-marker start-mark nil)
+             (set-marker end-mark nil)
              (unless (eq currbuff (current-buffer))
                (error "Undo function switched buffer"))
              (setq did-apply t)))
@@ -3940,7 +3956,16 @@ marker adjustment's corresponding (TEXT . POS) element."
 	((integerp (car undo-elt))
 	 ;; (BEGIN . END)
 	 (and (>= (car undo-elt) start)
-	      (<= (cdr undo-elt) end)))))
+	      (<= (cdr undo-elt) end)))
+        ((and (eq (nth 0 undo-elt) 'apply)
+              (integerp (nth 1 undo-elt))
+              (consp (nth 2 undo-elt))
+              (natnump (car (nth 2 undo-elt)))
+              (natnump (cdr (nth 2 undo-elt)))
+              (symbolp (nth 3 undo-elt)))
+         ;; (apply DELTA (BEG . END) FUN . ARGS)
+         (and (>= (car (nth 2 undo-elt)) start)
+	      (<= (cdr (nth 2 undo-elt)) end)))))
 
 (defun undo-elt-crosses-region (undo-elt start end)
   "Test whether UNDO-ELT crosses one edge of that region START ... END.
@@ -3974,7 +3999,13 @@ is not *inside* the region START...END."
     ;; (nil PROPERTY VALUE BEG . END)
     (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
      `(nil ,prop ,val . ,(undo-adjust-beg-end beg end deltas)))
-    ;; (apply DELTA START END FUN . ARGS)
+    ((and `(apply ,delta (,beg  . ,end) ,fun-name . ,args)
+          (guard (and (integerp delta) (natnump beg) (natnump end)
+                      (symbolp fun-name))))
+     (let* ((r2 (undo-adjust-beg-end beg end deltas))
+            (beg2 (car r2))
+            (end2 (cdr r2)))
+       `(apply ,delta (,beg2 . ,end2) ,fun-name . ,args)))
     ;; FIXME
     ;; All others return same elt
     (_ elt)))
@@ -4034,8 +4065,16 @@ with < or <= based on USE-<."
 	     ;; (BEGIN . END)
 	     (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
 	    ;; (apply DELTA BEG END FUNC . ARGS)
-	    ((and (eq (car undo-elt) 'apply) (integerp (nth 1 undo-elt)))
+	    ((and (eq (car undo-elt) 'apply)
+                  (integerp (nth 1 undo-elt))
+                  (natnump (nth 2 undo-elt)))
 	     (cons (nth 2 undo-elt) (nth 1 undo-elt)))
+	    ;; (apply DELTA (BEG . END) FUNC . ARGS)
+	    ((and (eq (car undo-elt) 'apply)
+                  (integerp (nth 1 undo-elt))
+                  (consp (nth 2 undo-elt))
+                  (natnump (car (nth 2 undo-elt))))
+	     (cons (car (nth 2 undo-elt)) (nth 1 undo-elt)))
 	    (t
 	     '(0 . 0)))
     '(0 . 0)))
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index 24fd47b88a7..073b1f415fd 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -539,5 +539,89 @@ Demonstrates bug 25599."
     (undo-boundary)
     (undo)))
 
+(defun undo-tests--mark-region (beg end)
+  (transient-mark-mode 1)
+  (goto-char beg)
+  (push-mark (point) t t)
+  (setq mark-active t)
+  (goto-char end))
+
+(defun undo-tests--selective-apply (fun)
+  (with-temp-buffer
+    (buffer-enable-undo)
+    (insert "1234567")
+    (undo-boundary)
+    (goto-char 4)
+    (let ((m1 (point-marker))
+          (m2 (point-marker))
+          (l buffer-undo-list))
+      (goto-char 1)
+      (insert "X")
+      (set-marker-insertion-type m2 t)
+      (delete-region 4 7)
+      (goto-char 4)
+      (insert "ABC")
+      (funcall fun l m1 m2)
+      (should (= m1 4))
+      (should (= m2 7))
+
+      (goto-char 3)
+      (insert "abcdef")
+      (should (equal (buffer-string) "X1abcdef2ABC67"))
+      (should (= m1 10))
+      (should (= m2 13))
+      (delete-region 3 4)
+      (should (equal (buffer-string) "X1bcdef2ABC67"))
+      (should (= m1 9))
+      (should (= m2 12))
+
+      (undo-boundary)
+      (undo-tests--mark-region 9 12)
+      (undo)
+
+      (should (equal (buffer-string) "X1bcdef234567"))
+      (should (= (point) 9))
+      (should (= m1 10))
+      (should (= m2 10)))))
+
+(ert-deftest undo-tests-selective-apply-1 ()
+  "Test selective undo without 'apply entries."
+  (undo-tests--selective-apply #'ignore))
+
+(defun undo-tests--undo-delete (beg _end text)
+  (goto-char beg)
+  (insert text)
+  (goto-char beg))
+
+(defun undo-tests--undo-insert (beg end)
+  (delete-region beg end))
+
+(defun undo-tests--adjust-markers (beg end &rest args)
+  (while args
+    (let* ((pair (pop args))
+           (m (car pair))
+           (offset (cdr pair))
+           (insertion-type (< offset 0))
+           (pos (if insertion-type end beg)))
+      (cond ((and (eq (marker-buffer m) (current-buffer))
+                  (eq (marker-insertion-type m) insertion-type)
+                  (= pos m))
+             (set-marker m (+ pos offset)))
+            (t
+             (message "ignoring adjustment: %s %s %s"
+                      beg end pair))))))
+
+(ert-deftest undo-tests-selective-apply-2 ()
+  "Test 'apply entries that emulate delete and insert entries."
+  (undo-tests--selective-apply
+   (lambda (l m1 m2)
+     (setq buffer-undo-list
+           `((apply -3 (4 . 7) undo-tests--undo-insert)
+             (apply 3 (4 . 4) undo-tests--undo-delete "345")
+             (apply 0 (4 . 7) undo-tests--adjust-markers
+                    (,m2 . -2) (,m1 . 1))
+             (apply -1 (1 . 1) undo-tests--undo-insert)
+             . ,l)))))
+
 (provide 'undo-tests)
 ;;; undo-tests.el ends here