How to collapse undo history?

Question

I'm working on an Emacs mode that lets you control Emacs with speech recognition. One of the problems I've ran into is that the way Emacs handles undo doesn't match how you would expect it to work when controlling by voice.

When the user speaks several words and then pauses, that's called an 'utterance.' An utterance may consist of multiple commands for Emacs to execute. It's often the case that the recognizer recognizes one or more commands within an utterance incorrectly. At that point I want to be able to say "undo" and have Emacs undo all actions done by the utterance, not just the last action within the utterance. In other words, I want Emacs to treat an utterance as a single command as far as undo is concerned, even when an utterance consists of multiple commands. I'd also like point to go back to exactly where it was before the utterance, I've noticed normal Emacs undo doesn't do this.

I have setup Emacs to get callbacks at the beginning and end of each utterance, so I can detect the situation, I just need to figure out what to have Emacs do. Ideally I'd call something like (undo-start-collapsing) and then (undo-stop-collapsing) and anything done inbetween would be magically collapsed into one record.

I did some trawling through the documentation and found undo-boundary, but it's the opposite of what I want -- I need to collapse all the actions within an utterance into one undo record, not split them up. I can use undo-boundary between utterances to make sure insertions are considered separate (Emacs by default considers consecutive insert actions to be one action up to some limit), but that's it.

Other complications:

• My speech recognition daemon sends some commands to Emacs by simulating X11 keypresses and sends some via emacsclient -e so, if there were say an (undo-collapse &rest ACTIONS) there's no central place I can wrap.
• I use undo-tree, not sure if this makes things more complicated. Ideally a solution would work with undo-tree and Emacs' normal undo behavior.
• What if one of the commands within an utterance is "undo" or "redo"? I'm thinking I could change the callback logic to always send these to Emacs as distinct utterances to keep things simpler, then it should be handled just like it would if I were using the keyboard.
• Stretch goal: An utterance may contain a command that switches the currently active window or buffer. In this case it's fine to have to say "undo" once separately in each buffer, I don't need it to be that fancy. But all the commands in a single buffer should still be grouped, so if I say "do-x do-y do-z switch-buffer do-a do-b do-c" then x,y,z should be one undo record in the original buffer and a,b,c should be one record in the switched to buffer.

Is there an easy way to do this? AFAICT there is nothing built-in but Emacs is vast and deep...

Update: I ended up using jhc's solution below with a little extra code. In the global before-change-hook I check if the buffer being changed is in a global list of buffers modified this utterance, if not it goes into the list and undo-collapse-begin is called. Then at the end of the utterance I iterate all the buffers in the list and call undo-collapse-end. Code below (md- added before function names for namespacing purposes):

(defvar md-utterance-changed-buffers nil)
(defvar-local md-collapse-undo-marker nil)

(defun md-undo-collapse-begin (marker)
  "Mark the beginning of a collapsible undo block.
This must be followed with a call to undo-collapse-end with a marker
eq to this one.

Taken from jch's stackoverflow answer here:
http://emacs.stackexchange.com/a/7560/2301
"
  (push marker buffer-undo-list))

(defun md-undo-collapse-end (marker)
  "Collapse undo history until a matching marker.

Taken from jch's stackoverflow answer here:
http://emacs.stackexchange.com/a/7560/2301"
  (cond
    ((eq (car buffer-undo-list) marker)
     (setq buffer-undo-list (cdr buffer-undo-list)))
    (t
     (let ((l buffer-undo-list))
       (while (not (eq (cadr l) marker))
         (cond
           ((null (cdr l))
            (error "md-undo-collapse-end with no matching marker"))
           ((eq (cadr l) nil)
            (setf (cdr l) (cddr l)))
           (t (setq l (cdr l)))))
       ;; remove the marker
       (setf (cdr l) (cddr l))))))

(defmacro md-with-undo-collapse (&rest body)
  "Execute body, then collapse any resulting undo boundaries.

Taken from jch's stackoverflow answer here:
http://emacs.stackexchange.com/a/7560/2301"
  (declare (indent 0))
  (let ((marker (list 'apply 'identity nil)) ; build a fresh list
        (buffer-var (make-symbol "buffer")))
    `(let ((,buffer-var (current-buffer)))
       (unwind-protect
           (progn
             (md-undo-collapse-begin ',marker)
             ,@body)
         (with-current-buffer ,buffer-var
           (md-undo-collapse-end ',marker))))))

(defun md-check-undo-before-change (beg end)
  "When a modification is detected, we push the current buffer
onto a list of buffers modified this utterance."
  (unless (or
           ;; undo itself causes buffer modifications, we
           ;; don't want to trigger on those
           undo-in-progress
           ;; we only collapse utterances, not general actions
           (not md-in-utterance)
           ;; ignore undo disabled buffers
           (eq buffer-undo-list t)
           ;; ignore read only buffers
           buffer-read-only
           ;; ignore buffers we already marked
           (memq (current-buffer) md-utterance-changed-buffers)
           ;; ignore buffers that have been killed
           (not (buffer-name)))
    (push (current-buffer) md-utterance-changed-buffers)
    (setq md-collapse-undo-marker (list 'apply 'identity nil))
    (undo-boundary)
    (md-undo-collapse-begin md-collapse-undo-marker)))

(defun md-pre-utterance-undo-setup ()
  (setq md-utterance-changed-buffers nil)
  (setq md-collapse-undo-marker nil))

(defun md-post-utterance-collapse-undo ()
  (unwind-protect
      (dolist (i md-utterance-changed-buffers)
        ;; killed buffers have a name of nil, no point
        ;; in undoing those
        (when (buffer-name i)
          (with-current-buffer i
            (condition-case nil
                (md-undo-collapse-end md-collapse-undo-marker)
              (error (message "Couldn't undo in buffer %S" i))))))
    (setq md-utterance-changed-buffers nil)
    (setq md-collapse-undo-marker nil)))

(defun md-force-collapse-undo ()
  "Forces undo history to collapse, we invoke when the user is
trying to do an undo command so the undo itself is not collapsed."
  (when (memq (current-buffer) md-utterance-changed-buffers)
    (md-undo-collapse-end md-collapse-undo-marker)
    (setq md-utterance-changed-buffers (delq (current-buffer) md-utterance-changed-buffers))))

(defun md-resume-collapse-after-undo ()
  "After the 'undo' part of the utterance has passed, we still want to
collapse anything that comes after."
  (when md-in-utterance
    (md-check-undo-before-change nil nil)))

(defun md-enable-utterance-undo ()
  (setq md-utterance-changed-buffers nil)
  (when (featurep 'undo-tree)
    (advice-add #'md-force-collapse-undo :before #'undo-tree-undo)
    (advice-add #'md-resume-collapse-after-undo :after #'undo-tree-undo)
    (advice-add #'md-force-collapse-undo :before #'undo-tree-redo)
    (advice-add #'md-resume-collapse-after-undo :after #'undo-tree-redo))
  (advice-add #'md-force-collapse-undo :before #'undo)
  (advice-add #'md-resume-collapse-after-undo :after #'undo)
  (add-hook 'before-change-functions #'md-check-undo-before-change)
  (add-hook 'md-start-utterance-hooks #'md-pre-utterance-undo-setup)
  (add-hook 'md-end-utterance-hooks #'md-post-utterance-collapse-undo))

(defun md-disable-utterance-undo ()
  ;;(md-force-collapse-undo)
  (when (featurep 'undo-tree)
    (advice-remove #'md-force-collapse-undo :before #'undo-tree-undo)
    (advice-remove #'md-resume-collapse-after-undo :after #'undo-tree-undo)
    (advice-remove #'md-force-collapse-undo :before #'undo-tree-redo)
    (advice-remove #'md-resume-collapse-after-undo :after #'undo-tree-redo))
  (advice-remove #'md-force-collapse-undo :before #'undo)
  (advice-remove #'md-resume-collapse-after-undo :after #'undo)
  (remove-hook 'before-change-functions #'md-check-undo-before-change)
  (remove-hook 'md-start-utterance-hooks #'md-pre-utterance-undo-setup)
  (remove-hook 'md-end-utterance-hooks #'md-post-utterance-collapse-undo))

(md-enable-utterance-undo)
;; (md-disable-utterance-undo)

Answer 1

Edit: emacs-29.1 adds a with-undo-amagamate macro see commit.

---

Here is an with-undo-amalgamate macro that uses Emacs-26 change-groups feature.

This is atomic-change-group with the following changes:

• Added undo-amalgamate-change-group.
• Removed call to cancel-change-group on failure.

It has the advantages that:

• It doesn't need to manipulate the undo data directly.
• It ensures undo data isn't truncated.

(defmacro with-undo-amalgamate (&rest body)
  "Like `progn' but perform BODY with amalgamated undo barriers.

This allows multiple operations to be undone in a single step.
When undo is disabled this behaves like `progn'."
  (declare (indent 0) (debug t))
  (let ((handle (make-symbol "--change-group-handle--")))
    `(let ((,handle (prepare-change-group))
           ;; Don't truncate any undo data in the middle of this,
           ;; otherwise Emacs might truncate part of the resulting
           ;; undo step: we want to mimic the behavior we'd get if the
           ;; undo-boundaries were never added in the first place.
           (undo-outer-limit nil)
           (undo-limit most-positive-fixnum)
           (undo-strong-limit most-positive-fixnum))
       (unwind-protect
           (progn
             (activate-change-group ,handle)
             ,@body)
         (progn
           (accept-change-group ,handle)
           (undo-amalgamate-change-group ,handle))))))

Answer 2

Interestingly enough, there appears to be no built-in function to do that.

The following code works by inserting a unique marker on the buffer-undo-list at the beginning of a collapsible block, and removing all boundaries (nil elements) at the end of a block, then removing the marker. In case something goes wrong, the marker is of the form (apply identity nil) to ensure that it does nothing if it remains on the undo list.

Ideally, you should use the with-undo-collapse macro, not the underlying functions. Since you mentioned that you cannot do the wrapping, make sure that you pass to the low-level functions markers that are eq, not just equal.

If the invoked code switches buffers, you must ensure that undo-collapse-end is called in the same buffer as undo-collapse-begin. In that case, only the undo entries in the initial buffer will be collapsed.

(defun undo-collapse-begin (marker)
  "Mark the beginning of a collapsible undo block.
This must be followed with a call to undo-collapse-end with a marker
eq to this one."
  (push marker buffer-undo-list))

(defun undo-collapse-end (marker)
  "Collapse undo history until a matching marker."
  (cond
    ((eq (car buffer-undo-list) marker)
     (setq buffer-undo-list (cdr buffer-undo-list)))
    (t
     (let ((l buffer-undo-list))
       (while (not (eq (cadr l) marker))
         (cond
           ((null (cdr l))
            (error "undo-collapse-end with no matching marker"))
           ((null (cadr l))
            (setf (cdr l) (cddr l)))
           (t (setq l (cdr l)))))
       ;; remove the marker
       (setf (cdr l) (cddr l))))))

 (defmacro with-undo-collapse (&rest body)
  "Execute body, then collapse any resulting undo boundaries."
  (declare (indent 0))
  (let ((marker (list 'apply 'identity nil)) ; build a fresh list
        (buffer-var (make-symbol "buffer")))
    `(let ((,buffer-var (current-buffer)))
       (unwind-protect
            (progn
              (undo-collapse-begin ',marker)
              ,@body)
         (with-current-buffer ,buffer-var
           (undo-collapse-end ',marker))))))

Here's an example of usage:

(defun test-no-collapse ()
  (interactive)
  (insert "toto")
  (undo-boundary)
  (insert "titi"))

(defun test-collapse ()
  (interactive)
  (with-undo-collapse
    (insert "toto")
    (undo-boundary)
    (insert "titi")))

Answer 3

Some changes to the undo machinery "recently" broke some hack viper-mode was using to do this kind of collapsing (for the curious, it's used in the following case: when you press ESC to finish an insertion/replacement/edition, Viper wants to collapse the whole change into a single undo step).

To fix it cleanly, we introduced a new function undo-amalgamate-change-group (which corresponds more or less to your undo-stop-collapsing) and reuses the existing prepare-change-group to mark the beginning (i.e. corresponds more or less to your undo-start-collapsing).

For reference, here's the corresponding new Viper code:

(viper-deflocalvar viper--undo-change-group-handle nil)
(put 'viper--undo-change-group-handle 'permanent-local t)

(defun viper-adjust-undo ()
  (when viper--undo-change-group-handle
    (undo-amalgamate-change-group
     (prog1 viper--undo-change-group-handle
       (setq viper--undo-change-group-handle nil)))))

(defun viper-set-complex-command-for-undo ()
  (and (listp buffer-undo-list)
       (not viper--undo-change-group-handle)
       (setq viper--undo-change-group-handle
             (prepare-change-group))))

This new function will appear in Emacs-26, so if you want to use it in the mean time, you can copy its definition (requires cl-lib):

(defun undo-amalgamate-change-group (handle)
  "Amalgamate changes in change-group since HANDLE.
Remove all undo boundaries between the state of HANDLE and now.
HANDLE is as returned by `prepare-change-group'."
  (dolist (elt handle)
    (with-current-buffer (car elt)
      (setq elt (cdr elt))
      (when (consp buffer-undo-list)
        (let ((old-car (car-safe elt))
              (old-cdr (cdr-safe elt)))
          (unwind-protect
              (progn
                ;; Temporarily truncate the undo log at ELT.
                (when (consp elt)
                  (setcar elt t) (setcdr elt nil))
                (when
                    (or (null elt)        ;The undo-log was empty.
                        ;; `elt' is still in the log: normal case.
                        (eq elt (last buffer-undo-list))
                        ;; `elt' is not in the log any more, but that's because
                        ;; the log is "all new", so we should remove all
                        ;; boundaries from it.
                        (not (eq (last buffer-undo-list) (last old-cdr))))
                  (cl-callf (lambda (x) (delq nil x))
                      (if (car buffer-undo-list)
                          buffer-undo-list
                        ;; Preserve the undo-boundaries at either ends of the
                        ;; change-groups.
                        (cdr buffer-undo-list)))))
            ;; Reset the modified cons cell ELT to its original content.
            (when (consp elt)
              (setcar elt old-car)
              (setcdr elt old-cdr))))))))