scratch/undo-apply 1273c1759e1 2/2: Make handling of partially selected undo items customizable

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

    Make handling of partially selected undo items customizable
    
    Introduce a variable undo-partially-in-region-policy,
    that can have one of the values:
      - partial-ignore
      - partial-stop
      - partial-expand
    
    Ignoring partially selected items seems like a bug, but the other two
    choices break existing tests.
    
    * lisp/simple.el (undo-partially-in-region-policy): New variable.
    (undo-make-selective-list): Implement the different policies.
    (undo--region): New helper.
    * test/src/undo-tests.el (undo-test-region-example)
    (undo-tests-selective-apply-3, undo-tests-selective-apply-4): Amend for
    the different policies.
    * test/lisp/simple-tests.el (simple-tests--undo-apply): Ditto.
---
 lisp/simple.el            | 50 ++++++++++++++++++++++++++++++++++++++++++-----
 test/lisp/simple-tests.el | 12 ++++++++++--
 test/src/undo-tests.el    | 44 ++++++++++++++++++++++++++++++-----------
 3 files changed, 88 insertions(+), 18 deletions(-)

diff --git a/lisp/simple.el b/lisp/simple.el
index 7058a79100b..6416c30577e 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -3818,6 +3818,12 @@ are ignored.  If BEG and END are nil, all undo elements are used."
 	    (undo-make-selective-list (min beg end) (max beg end))
 	  buffer-undo-list)))
 
+(defcustom undo-partially-in-region-policy 'partial-ignore
+  "Policy for undo items that are only partially selected."
+  :type '(choice (const partial-ignore)
+                 (const partial-stop)
+                 (const partial-expand)))
+
 ;; The positions given in elements of the undo list are the positions
 ;; as of the time that element was recorded to undo history.  In
 ;; general, subsequent buffer edits render those positions invalid in
@@ -3912,7 +3918,7 @@ list can be applied to the current buffer."
         (let ((adjusted-undo-elt (undo-adjust-elt undo-elt
                                                   undo-deltas)))
           (cl-ecase (undo-elt-in-region adjusted-undo-elt start end
-                                        'partial)
+                                        undo-partially-in-region-policy)
             ((t)
              (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
              (push adjusted-undo-elt selective-list)
@@ -3922,17 +3928,30 @@ list can be applied to the current buffer."
                         (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)
+                   (push (pop list-i) selective-list))))
+             )
+            ((nil partial-ignore)
              (let ((delta (undo-delta undo-elt)))
                (when (/= 0 (cdr delta))
                  (push delta undo-deltas))))
-            (partial
+            (partial-stop
              ;; 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))))))
+             (setq ulist nil))
+            (partial-expand
+             (let* ((region (undo--region adjusted-undo-elt))
+                    (rstart (car region))
+                    (rend (cdr region)))
+               (setq start (min start rstart))
+               (setq end (max end rend)))
+             (push adjusted-undo-elt selective-list)
+             (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)))))))))
       (pop ulist))
     (nreverse selective-list)))
 
@@ -4100,6 +4119,27 @@ with < or <= based on USE-<."
 	     '(0 . 0)))
     '(0 . 0)))
 
+(defun undo--region (undo-elt)
+  (pcase-exhaustive undo-elt
+    ((and `(,beg . ,end) (guard (and (natnump beg) (natnump end))))
+     undo-elt)
+    ((or (and `(,text . ,pos) (guard (and (stringp text) (integerp pos))))
+         (and pos (pred natnump)))
+      (let ((p (abs pos)))
+        (cons p p)))
+    ((or `(t . _)
+         (and `(apply ,fun-name) (guard (symbolp fun-name))))
+     t)
+    ((or `(nil _ _ ,beg . ,end)
+         (and `(apply ,delta ,beg ,end . ,_)
+              (guard (and (integerp delta) (natnump beg))))
+         (and `(apply ,delta (,beg . ,end) . ,_)
+              (guard (and (integerp delta) (natnump beg)))))
+     (cons beg end))
+    ((or (and `(,m . ,_) (guard (markerp m)))
+         `nil)
+     nil)))
+
 ;;; Default undo-boundary addition
 ;;
 ;; This section adds a new undo-boundary at either after a command is
diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el
index 464cc51c152..e2ab7e7daf2 100644
--- a/test/lisp/simple-tests.el
+++ b/test/lisp/simple-tests.el
@@ -591,8 +591,16 @@ See bug#35036."
         (goto-char midbeg)
         (set-mark midend)
         (setq last-command 'something-else) ;Not `undo', so we start a new run.
-        (undo '(4))
-        (should (equal (buffer-substring midbeg midend) "midmid")))
+        (cl-ecase undo-partially-in-region-policy
+          (partial-ignore
+           (undo '(4))
+           (should (equal (buffer-substring midbeg midend) "midmid")))
+          (partial-stop
+           (should-error (undo '(4)) :type 'user-error)
+           (should (equal (buffer-substring midbeg midend) "mid\nmid")))
+          (partial-expand
+           (undo '(4))
+           (should (equal (buffer-substring midbeg midend) "mid\nmid")))))
       ;; (progn
       ;;   (goto-char (point-min))
       ;;   ;; FIXME: `comment-region-default' puts a too conservative boundary
diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el
index 1dc52c83519..638b64a9518 100644
--- a/test/src/undo-tests.el
+++ b/test/src/undo-tests.el
@@ -315,10 +315,19 @@ undo-make-selective-list."
     (push-mark 2 t t)
     (setq mark-active t)
     (goto-char 6)
-    (undo)
-    (undo-boundary)
-    (should (string= (buffer-string)
-                     "ccaaaddd"))))
+    (cl-ecase undo-partially-in-region-policy
+      (partial-ignore
+       (undo)
+       (should (string= (buffer-string)
+                        "ccaaaddd")))
+      (partial-stop
+       (should-error (undo) :type 'user-error)
+       (should (string= (buffer-string)
+                        "ccaabaddd")))
+      (partial-expand
+       (undo)
+       (should (string= (buffer-string)
+                        "aabaddd"))))))
 
 (ert-deftest undo-test-region-eob ()
   "Test undo in region of a deletion at EOB, demonstrating bug 16411."
@@ -668,8 +677,16 @@ Demonstrates bug 25599."
     (undo-boundary)
     ;; select "B"
     (undo-tests--mark-region 2 3)
-    (should-error (undo) :type 'user-error)
-    (should (equal (buffer-string) "aBDe"))))
+    (cl-ecase undo-partially-in-region-policy
+      (partial-ignore
+       (undo)
+       (should (equal (buffer-string) "aBcDe")))
+      (partial-stop
+       (should-error (undo) :type 'user-error)
+       (should (equal (buffer-string) "aBDe")))
+      (partial-expand
+       (undo)
+       (should (equal (buffer-string) "abcde"))))))
 
 (ert-deftest undo-tests-selective-apply-4 ()
   "Test partially selected \"undo-insert\" (BEG . END) entries."
@@ -688,11 +705,16 @@ Demonstrates bug 25599."
     (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"))))
+    (cl-ecase undo-partially-in-region-policy
+      (partial-ignore
+       (undo)
+       (should (equal (buffer-string) "1ab2345")))
+      (partial-stop
+       (should-error (undo) :type 'user-error)
+       (should (equal (buffer-string) "1ab25")))
+      (partial-expand
+       (undo)
+       (should (equal (buffer-string) "12345"))))))
 
 (provide 'undo-tests)
 ;;; undo-tests.el ends here