scratch/undo-apply a34caecb046 3/3: Improve undo-in-region support for combine-change-calls

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

    Improve undo-in-region support for combine-change-calls
    
    * lisp/subr.el (combine-change-calls-1): Use the new 'apply entry
    variant for the buffer-undo-list.
    (undo--wrap-and-run-primitive-undo): Adjust the undo entries if the
    region has moved.
    * test/src/undo-tests.el (undo-test-combine-change-calls-4): New test.
---
 lisp/subr.el           | 22 ++++++++++++++++------
 test/src/undo-tests.el | 22 ++++++++++++++++++++++
 2 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 60a57688f73..04ca6a042e9 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -5715,8 +5715,7 @@ the function `undo--wrap-and-run-primitive-undo'."
 	    ;; body-undo-list ...
 	    (push (list 'apply
 			(- end end-marker)
-			beg
-			(marker-position end-marker)
+			(cons beg (marker-position end-marker))
 			#'undo--wrap-and-run-primitive-undo
 			beg (marker-position end-marker)
 			body-undo-list)
@@ -5756,7 +5755,7 @@ the function `undo--wrap-and-run-primitive-undo'."
   (declare (debug (form form def-body)) (indent 2))
   `(combine-change-calls-1 ,beg ,end (lambda () ,@body)))
 
-(defun undo--wrap-and-run-primitive-undo (beg end list)
+(defun undo--wrap-and-run-primitive-undo (beg end orig-beg orig-end list)
   "Call `primitive-undo' on the undo elements in LIST.
 
 This function is intended to be called purely by `undo' as the
@@ -5771,9 +5770,20 @@ Additionally the fresh \"redo\" elements which are generated on
 
 Undo elements of this form are generated by the macro
 `combine-change-calls'."
-  (combine-change-calls beg end
-			(while list
-			  (setq list (primitive-undo 1 list)))))
+  (let* ((beg-delta (- orig-beg beg))
+         (end-delta (- orig-end end))
+         (list (cond ((/= beg-delta end-delta)
+                      (error "Not yet implemented"))
+                     ((= beg-delta 0)
+                      list)
+                     (t
+                      (let ((deltas (list (cons orig-beg beg-delta))))
+                        (mapcar (lambda (elt)
+                                  (undo-adjust-elt elt deltas))
+                                list))))))
+    (combine-change-calls beg end
+      (while list
+	(setq list (primitive-undo 1 list))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index 073b1f415fd..3722b913ebb 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -511,6 +511,28 @@ Case 3: a file-visiting buffer with `buffer-undo-list' nil and
         (replace-match "Z "))
       (should (= (length buffer-undo-list) 1)))))
 
+(ert-deftest undo-test-combine-change-calls-4 ()
+  "Test `combine-change-calls' in combination with undo-in-region."
+  (with-temp-buffer
+    (buffer-enable-undo)
+    (dolist (s '("A" "B" "C" "D"))
+      (insert s)
+      (undo-boundary))
+    (combine-change-calls (point-min) (point-max)
+      (goto-char (point-min))
+      (while (re-search-forward "[BD]" nil t)
+        (delete-char -1)
+        (insert "xy")))
+    (goto-char (point-min))
+    (insert "<")
+    (goto-char (point-max))
+    (insert ">")
+    (undo-boundary)
+    (should (equal (buffer-string) "<AxyCxy>"))
+    (undo-tests--mark-region 2 8)
+    (undo)
+    (should (equal (buffer-string) "<ABCD>"))))
+
 (defun undo-test-all (&optional interactive)
   "Run all tests for \\[undo]."
   (interactive "p")