scratch/undo-apply 4fa4a8dde14 1/2: Make undo-in-region more cautious

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

    Make undo-in-region more cautious
    
    If the region of an entry in the undo-list is only partially covered by
    the the active region, then ingore this entry and the older entries even
    if they are in the active region.
    
    Previously, the older entries were applied.  The older entries, in
    particular 'apply entries, could depend on the changes caused by the
    partially selected entry.  Ignoring the older entries is safer, but
    perhaps too conservative.
    
    * lisp/simple.el (undo-elt-in-region): New argument PARTIAL, that is
    returned if the element is partially covered by the region.
    (undo--region-in-region): New helper.
    (undo-make-selective-list): If an entry is only partially covered by the
    region, stop adding any more entries.
    * test/src/undo-tests.el (undo-tests-selective-apply-3)
    (undo-tests-selective-apply-4): New tests.
    * test/lisp/vc/diff-mode-tests.el (diff-mode-tests-selective-undo): Make
    the selected region smaller, so that we don't partially cover and 'apply
    entry.
---
 lisp/simple.el                  | 65 +++++++++++++++++++++++++++--------------
 test/lisp/vc/diff-mode-tests.el |  3 +-
 test/src/undo-tests.el          | 49 +++++++++++++++++++++++++++++++
 3 files changed, 94 insertions(+), 23 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index da3fdd71147..7058a79100b 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3911,26 +3911,44 @@ list can be applied to the current buffer."
        (t
         (let ((adjusted-undo-elt (undo-adjust-elt undo-elt
                                                   undo-deltas)))
-          (if (undo-elt-in-region adjusted-undo-elt start end)
-              (progn
-                (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
-                (push adjusted-undo-elt selective-list)
-                ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was
-                ;; kept.  primitive-undo may discard them later.
-                (when (and (stringp (car-safe adjusted-undo-elt))
-                           (integerp (cdr-safe adjusted-undo-elt)))
-                  (let ((list-i (cdr ulist)))
-                    (while (markerp (car-safe (car list-i)))
-                      (push (pop list-i) selective-list)))))
-            (let ((delta (undo-delta undo-elt)))
-              (when (/= 0 (cdr delta))
-                (push delta undo-deltas)))))))
+          (cl-ecase (undo-elt-in-region adjusted-undo-elt start end
+                                        'partial)
+            ((t)
+             (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
+             (push adjusted-undo-elt selective-list)
+             ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was
+             ;; kept.  primitive-undo may discard them later.
+             (when (and (stringp (car-safe adjusted-undo-elt))
+                        (integerp (cdr-safe adjusted-undo-elt)))
+               (let ((list-i (cdr ulist)))
+                 (while (markerp (car-safe (car list-i)))
+                   (push (pop list-i) selective-list)))))
+            ((nil)
+             (let ((delta (undo-delta undo-elt)))
+               (when (/= 0 (cdr delta))
+                 (push delta undo-deltas))))
+            (partial
+             ;; Stop searching for more applicable elements, because we
+             ;; aren't sure whether subsequent elements depend on the
+             ;; changes caused by this one; in particular for 'apply
+             ;; entries.
+             (setq ulist nil))))))
       (pop ulist))
     (nreverse selective-list)))
 
-(defun undo-elt-in-region (undo-elt start end)
+(defun undo--region-in-region (start1 end1 start2 end2 partial)
+  (cond ((<= start2 start1 end1 end2)
+         t)
+        ((or (<= start1 start2 end2 end1)
+             (and (<= start2 start1) (< start1 end2))
+             (and (< start2 end1) (<= end1 end2)))
+         partial)
+        (t
+         nil)))
+
+(defun undo-elt-in-region (undo-elt start end &optional partial)
   "Determine whether UNDO-ELT falls inside the region START ... END.
-If it crosses the edge, we return nil.
+If it crosses the edge, we return PARTIAL; nil otherwise.
 
 Generally this function is not useful for determining
 whether (MARKER . ADJUSTMENT) undo elements are in the region,
@@ -3951,12 +3969,12 @@ marker adjustment's corresponding (TEXT . POS) element."
 	((null (car undo-elt))
 	 ;; (nil PROPERTY VALUE BEG . END)
 	 (let ((tail (nthcdr 3 undo-elt)))
-	   (and (>= (car tail) start)
-		(<= (cdr tail) end))))
+           (undo--region-in-region (car tail) (cdr tail)
+                                   start end partial)))
 	((integerp (car undo-elt))
 	 ;; (BEGIN . END)
-	 (and (>= (car undo-elt) start)
-	      (<= (cdr undo-elt) end)))
+         (undo--region-in-region (car undo-elt) (cdr undo-elt)
+                                 start end partial))
         ((and (eq (nth 0 undo-elt) 'apply)
               (integerp (nth 1 undo-elt))
               (consp (nth 2 undo-elt))
@@ -3964,8 +3982,11 @@ marker adjustment's corresponding (TEXT . POS) element."
               (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)))))
+         (let* ((_delta (nth 1 undo-elt))
+                (region (nth 2 undo-elt))
+                (rbeg (car region))
+                (rend (cdr region)))
+           (undo--region-in-region rbeg rend start end partial)))))
 
 (defun undo-elt-crosses-region (undo-elt start end)
   "Test whether UNDO-ELT crosses one edge of that region START ... END.
diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el
index 13cb81eaa10..94e0c456a98 100644
--- a/test/lisp/vc/diff-mode-tests.el
+++ b/test/lisp/vc/diff-mode-tests.el
@@ -946,7 +946,8 @@ index 0000000..3456789
               (goto-char (point-min))
               (should (not (re-search-forward "(defun foo ()" nil t)))
               (re-search-forward (regexp-quote "(defun bar ()"))
-              (diff-mode-tests--mark-region (point-min) (point))
+              (diff-mode-tests--mark-region (point-min)
+                                            (line-beginning-position))
 	      (undo-boundary)
 	      (undo)
               (should (equal (buffer-string) v3)))
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index 3722b913ebb..1dc52c83519 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -645,5 +645,54 @@ Demonstrates bug 25599."
              (apply -1 (1 . 1) undo-tests--undo-insert)
              . ,l)))))
 
+(ert-deftest undo-tests-selective-apply-3 ()
+  "Test partially selected 'apply entries."
+  ;; If the active region covers the region of an apply entry only
+  ;; partially, then the 'apply entry and all older entries should be
+  ;; ignored.
+  (with-temp-buffer
+    (buffer-enable-undo)
+    (insert "abcde")
+    (undo-boundary)
+    (delete-region 3 4)
+    (should (equal (buffer-string) "abde"))
+    (let ((l buffer-undo-list))
+      (upcase-region 2 4)
+      (setq buffer-undo-list
+            `((apply 0 (2 . 4) downcase-region)
+              . ,l)))
+    (should (equal (buffer-string) "aBDe"))
+    (should (equal buffer-undo-list
+                   '((apply 0 (2 . 4) downcase-region)
+                     ("c" . 3) 6 nil (1 . 6) (t . 0))))
+    (undo-boundary)
+    ;; select "B"
+    (undo-tests--mark-region 2 3)
+    (should-error (undo) :type 'user-error)
+    (should (equal (buffer-string) "aBDe"))))
+
+(ert-deftest undo-tests-selective-apply-4 ()
+  "Test partially selected \"undo-insert\" (BEG . END) entries."
+  (with-temp-buffer
+    (buffer-enable-undo)
+    (insert "12345")
+    (undo-boundary)
+    (delete-region 3 5)
+    (should (equal (buffer-string) "125"))
+    (goto-char 2)
+    (insert "ab")
+    (should (equal (buffer-string) "1ab25"))
+    (undo-boundary)
+    (goto-char 3)
+    ;; select "b2"
+    (undo-tests--mark-region 3 5)
+    (should (equal buffer-undo-list
+                   '(nil (2 . 4) ("34" . 3) 6 nil (1 . 6) (t . 0))))
+    ;; The entry (2 . 4) "undo-insert" is ignored because it is only
+    ;; partially covered by the region (3 . 5).  Older entries are still
+    ;; undone.  Not sure if this is a bug or a feature.
+    (undo)
+    (should (equal (buffer-string) "1ab2345"))))
+
 (provide 'undo-tests)
 ;;; undo-tests.el ends here