bug#16411: undo-only bugs

[Barry OReilly]

I am pursuing a solution more like the first one I suggested in bug
16411 and have a preliminary patch I would like to get some feedback
on. undo-tests pass but the patch does not fix the bug yet. The patch
does two major things:

   1: Defines and populates a new undo-redo-table
   2: Uses closures to lazily compute pending undo elements

Item 1 is the crucial one. The undo-redo-table is somewhat like
undo-equiv-table, except that instead of mapping equal buffer states,
it maps undo elements to what they undid. This conveys better
information.

Mapping equal buffer states with undo-equiv-table is not workable,
because undos in region generally don't return the user to a buffer
state that actually existed before. Consider: insert A, insert B, undo
in region of A. The buffer has just B for the first time.

Existing use of undo-equiv-table can readily switch to use
undo-redo-table, as described in the obsoletion note of the patch. The
converse, using undo-equiv-table instead of undo-redo-table, would
require traversing backwards in the singly linked list.

The reason undo-redo-table maps at the element level, as opposed to
the change group level, is because in the case of undo in region with
a prefix arg, the newly created change group needs to reference
subsets of potentially many prior change groups.

Having undo elements reference what they undid would help solve
several issues:

   1: undo-only in region doesn't work.
   2: Normal undo-only after an undo in region doesn't work. I've
      previously outlined how the solution would use the
      undo-redo-table.
   3: Undo in region has counter intuitive behavior as described in
      the FIXME of simple.el describing undo in region.
   4: Deleting X bytes, then doing Y iterations of undo and redo
      causes undo history to grow about X*Y. To grow proportional to Y
      should be achievable: set undo-in-progress to the in progress
      element, and the C level undo recording to use it and
      undo-redo-table to find the eq Lisp_String.
   5: Undo Tree should more tightly integrate with the builtin undo
      system. To do so, it needs sufficient information to visualize
      the buffer-undo-list as a tree. Undo Tree has a means to
      visualize undo in regions, so undo-equiv-table is inadequate.

There are variations on how elements could reference what they undid,
but fundamentally I think it is essential. I wish to know how you like
the direction the patch is going as I proceed to solve some problems
building upon it.

The patch ignores whitespace.

diff --git a/lisp/simple.el b/lisp/simple.el
index 1484339..09b3a5f 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2054,20 +2054,32 @@ Go to the history element by the absolute
history position HIST-POS."
 ;Put this on C-x u, so we can force that rather than C-_ into startup msg
 (define-obsolete-function-alias 'advertised-undo 'undo "23.2")

+(defvar undo-redo-table (make-hash-table :test 'eq :weakness t)
+  "Hash table mapping undo elements created by an undo command to
+the undo element they undid.  Specifically, the keys and values
+are eq to cons of buffer-undo-list.  The hash table is weak so as
+truncated undo elements can be garbage collected.")
 (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
   "Table mapping redo records to the corresponding undo one.
 A redo record for undo-in-region maps to t.
 A redo record for ordinary undo maps to the following (earlier) undo.")
+(make-obsolete-variable
+ 'undo-equiv-table
+ "Use undo-redo-table instead.  For non regional undos, (gethash
+k undo-equiv-table) is the same as taking (gethash k
+undo-redo-table) and scanning forward one change group."
+ "24.5")

 (defvar undo-in-region nil
-  "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
+  "Non-nil during an undo in region.")

 (defvar undo-no-redo nil
   "If t, `undo' doesn't go through redo entries.")

 (defvar pending-undo-list nil
-  "Within a run of consecutive undo commands, list remaining to be undone.
-If t, we undid all the way to the end of it.")
+  "Within a run of consecutive undo commands, is a tail of
+buffer-undo-list for remaining undo elements, or a closure to
+generate them.  If t, there is no more to undo.")

 (defun undo (&optional arg)
   "Undo some previous changes.
@@ -2115,9 +2127,10 @@ as an argument limits undo to changes within
the current region."
       (undo-more 1))
     ;; If we got this far, the next command should be a consecutive undo.
     (setq this-command 'undo)
-    ;; Check to see whether we're hitting a redo record, and if
-    ;; so, ask the user whether she wants to skip the redo/undo pair.
-    (let ((equiv (gethash pending-undo-list undo-equiv-table)))
+    ;; Check to see whether we're hitting a redo record
+    (let ((equiv (if (functionp pending-undo-list)
+                     t
+                   (gethash pending-undo-list undo-equiv-table))))
       (or (eq (selected-window) (minibuffer-window))
          (setq message (format "%s%s!"
                                 (if (or undo-no-redo (not equiv))
@@ -2202,40 +2215,48 @@ Some change-hooks test this variable to do
something different.")
   "Undo back N undo-boundaries beyond what was already undone recently.
 Call `undo-start' to get ready to undo recent changes,
 then call `undo-more' one or more times to undo them."
-  (or (listp pending-undo-list)
+  (when (eq pending-undo-list t)
     (user-error (concat "No further undo information"
                         (and undo-in-region " for region"))))
   (let ((undo-in-progress t))
-    ;; Note: The following, while pulling elements off
-    ;; `pending-undo-list' will call primitive change functions which
-    ;; will push more elements onto `buffer-undo-list'.
-    (setq pending-undo-list (primitive-undo n pending-undo-list))
-    (if (null pending-undo-list)
+    ;; Note: The following changes the buffer, and so calls primitive
+    ;; change functions that push more elements onto
+    ;; `buffer-undo-list'.
+    (unless (if (functionp pending-undo-list)
+                (undo-using-generator pending-undo-list n)
+              (setq pending-undo-list
+                    (primitive-undo n pending-undo-list)))
+      ;; Reached the end of undo history
       (setq pending-undo-list t))))

 (defun primitive-undo (n list)
-  "Undo N records from the front of the list LIST.
+  "Undo N change groups from the front of the list LIST.
 Return what remains of the list."
+  (undo-using-generator
+   (lambda (&optional option)
+     (prog1 (cons (car list) list)
+       (unless (eq option 'peek) (pop list))))
+   n)
+  list)

-  ;; This is a good feature, but would make undo-start
-  ;; unable to do what is expected.
-  ;;(when (null (car (list)))
-  ;;  ;; If the head of the list is a boundary, it is the boundary
-  ;;  ;; preceding this command.  Get rid of it and don't count it.
-  ;;  (setq list (cdr list))))
-
+(defun undo-using-generator (generator n)
+  "Undo N change groups using a GENERATOR closure to get
+successive undo elements. Return the last association returned
+from GENERATOR or nil if the end of undo history was reached."
   (let ((arg n)
         ;; In a writable buffer, enable undoing read-only text that is
         ;; so because of text properties.
         (inhibit-read-only t)
         ;; Don't let `intangible' properties interfere with undo.
         (inhibit-point-motion-hooks t)
-        ;; We use oldlist only to check for EQ.  ++kfs
-        (oldlist buffer-undo-list)
-        (did-apply nil)
-        (next nil))
+        next-assoc)
     (while (> arg 0)
-      (while (setq next (pop list))     ;Exit inner loop at undo boundary.
+      ;; Exit this inner loop at an undo boundary, which would be
+      ;; next-assoc of (nil . nil).
+      (while (car (setq next-assoc (funcall generator)))
+        (let ((next (car next-assoc))
+              (orig-tail (cdr next-assoc))
+              (prior-undo-list buffer-undo-list))
           ;; Handle an integer by setting point to that value.
           (pcase next
             ((pred integerp) (goto-char next))
@@ -2289,21 +2310,27 @@ Return what remains of the list."
                  (apply fun-args))
                (unless (eq currbuff (current-buffer))
                  (error "Undo function switched buffer"))
-             (setq did-apply t)))
+               ;; Make sure an apply entry produces at least one undo entry,
+               ;; so the test in `undo' for continuing an undo series
+               ;; will work right.
+               (when (eq prior-undo-list buffer-undo-list)
+                 (push (list 'apply 'cdr nil) buffer-undo-list))))
             ;; Element (STRING . POS) means STRING was deleted.
             (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
              (when (let ((apos (abs pos)))
                      (or (< apos (point-min)) (> apos (point-max))))
                (error "Changes to be undone are outside visible
portion of buffer"))
-           (let (valid-marker-adjustments)
+             (let (valid-marker-adjustments
+                   ahead)
                ;; Check that marker adjustments which were recorded
                ;; with the (STRING . POS) record are still valid, ie
                ;; the markers haven't moved.  We check their validity
                ;; before reinserting the string so as we don't need to
                ;; mind marker insertion-type.
-             (while (and (markerp (car-safe (car list)))
-                         (integerp (cdr-safe (car list))))
-               (let* ((marker-adj (pop list))
+               (while (and (setq ahead (funcall generator 'peek))
+                           (markerp (car-safe (car ahead)))
+                           (integerp (cdr-safe (car ahead))))
+                 (let* ((marker-adj (car (funcall generator)))
                         (m (car marker-adj)))
                    (and (eq (marker-buffer m) (current-buffer))
                         (= pos m)
@@ -2331,16 +2358,13 @@ Return what remains of the list."
                (set-marker marker
                            (- marker offset)
                            (marker-buffer marker))))
-          (_ (error "Unrecognized entry in undo list %S" next))))
+            (_ (error "Unrecognized entry in undo list %S" next)))
+          ;; Map the new undo element to what it undid.  Not aware yet
+          ;; of cases where we want to map all new elements.
+          (unless (eq prior-undo-list buffer-undo-list)
+            (puthash buffer-undo-list orig-tail undo-redo-table))))
       (setq arg (1- arg)))
-    ;; Make sure an apply entry produces at least one undo entry,
-    ;; so the test in `undo' for continuing an undo series
-    ;; will work right.
-    (if (and did-apply
-             (eq oldlist buffer-undo-list))
-        (setq buffer-undo-list
-              (cons (list 'apply 'cdr nil) buffer-undo-list))))
-  list)
+    next-assoc))

 ;; Deep copy of a list
 (defun undo-copy-list (list)
@@ -2353,16 +2377,16 @@ Return what remains of the list."
     elt))

 (defun undo-start (&optional beg end)
-  "Set `pending-undo-list' to the front of the undo list.
-The next call to `undo-more' will undo the most recently made change.
-If BEG and END are specified, then only undo elements
-that apply to text between BEG and END are used; other undo elements
-are ignored.  If BEG and END are nil, all undo elements are used."
+  "Set `pending-undo-list' to begin a run of undos.  The next
+call to `undo-more' will undo the next change group.  If BEG and
+END are specified, then only undo elements that apply to text
+between BEG and END are used; other undo elements are ignored.
+If BEG and END are nil, all undo elements are used."
   (if (eq buffer-undo-list t)
       (user-error "No undo information in this buffer"))
   (setq pending-undo-list
        (if (and beg end (not (= beg end)))
-           (undo-make-selective-list (min beg end) (max beg end))
+           (undo-make-regional-generator (min beg end) (max beg end))
          buffer-undo-list)))

 ;; The positions given in elements of the undo list are the positions
@@ -2424,30 +2448,39 @@ are ignored.  If BEG and END are nil, all undo
elements are used."
 ;; "ccaabad", as though the first "d" became detached from the
 ;; original "ddd" insertion.  This quirk is a FIXME.

-(defun undo-make-selective-list (start end)
-  "Return a list of undo elements for the region START to END.
-The elements come from `buffer-undo-list', but we keep only the
-elements inside this region, and discard those outside this
-region.  The elements' positions are adjusted so as the returned
-list can be applied to the current buffer."
+(defun undo-make-regional-generator (start end)
+  "Make a closure that will return the next undo element
+association in the region START to END each time it is called, in
+the form (ADJUSTED-ELT . ORIG-UNDO-LIST).  ADJUSTED-ELT is an
+undo element with adjusted positions and ORIG-UNDO-LIST is a cons
+of buffer-undo-list whose car is the original unadjusted undo
+element.  ADJUSTED-ELT may or may not be eq to (car
+ORIG-UNDO-LIST).
+
+The use of a closure allows for lazy adjustment of elements of
+the buffer-undo-list as needed for successive undo commands."
   (let ((ulist buffer-undo-list)
-        ;; A list of position adjusted undo elements in the region.
-        (selective-list (list nil))
+        ;; (ADJUSTED-ELT . ORIG-UNDO-LIST) associations to be returned
+        ;; from closure
+        (selective-list (list (cons nil nil)))
+        prev-assoc
         ;; A list of undo-deltas for out of region undo elements.
-        undo-deltas
-        undo-elt)
-    (while ulist
-      (setq undo-elt (car ulist))
+        undo-deltas)
+    (lambda (&optional option)
+      ;; Update selective-list with potential returns if necessary
+      (while (and ulist (not selective-list))
+        (let ((undo-elt (car ulist)))
           (cond
            ((null undo-elt)
-        ;; Don't put two nils together in the list
-        (when (car selective-list)
-          (push nil selective-list)))
+            ;; Don't put two undo boundaries, represented as (nil
+            ;; . nil), together in the list
+            (unless (equal (cons nil nil) prev-assoc)
+              (push (cons nil nil) selective-list)))
            ((and (consp undo-elt) (eq (car undo-elt) t))
             ;; This is a "was unmodified" element.  Keep it
             ;; if we have kept everything thus far.
             (when (not undo-deltas)
-          (push undo-elt selective-list)))
+              (push (cons undo-elt ulist) selective-list)))
            ;; Skip over marker adjustments, instead relying
            ;; on finding them after (TEXT . POS) elements
            ((markerp (car-safe undo-elt))
@@ -2458,19 +2491,37 @@ list can be applied to the current buffer."
               (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)
+                    (push (cons adjusted-undo-elt ulist) 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 ((marker-adj (pop list-i)))
+                            (push (cons marker-adj marker-adj)
+                                  selective-list))))
+                      (setq selective-list (nreverse selective-list))))
                 (let ((delta (undo-delta undo-elt)))
                   (when (/= 0 (cdr delta))
-                (push delta undo-deltas)))))))
+                    (push delta undo-deltas))))))))
         (pop ulist))
+      (if (eq option 'peek)
+          (car selective-list)
+        (setq prev-assoc (pop selective-list))))))
+
+(defun undo-make-selective-list (start end)
+  "Realize a full selective undo list per
+undo-make-regional-generator."
+  (let ((selective-list nil)
+        (gen (undo-make-regional-generator start end))
+        elt)
+    (while (setq elt (funcall gen))
+      (push selective-list (car elt)))
     (nreverse selective-list)))
+(make-obsolete 'undo-make-selective-list
+               "Use undo-make-regional-generator instead."
+               "24.5")

 (defun undo-elt-in-region (undo-elt start end)
   "Determine whether UNDO-ELT falls inside the region START ... END.