[elpa] externals/undo-tree 5d2f73c 057/195: Implemented support for marker entries in undo changesets!

[Stefan Monnier]

branch: externals/undo-tree
commit 5d2f73cd2bc4642a990f4853c6cc8dfbe82782ac
Author: Toby S. Cubitt <toby-undo-tree@dr-qubit.org>
Commit: Toby S. Cubitt <toby-undo-tree@dr-qubit.org>

    Implemented support for marker entries in undo changesets!
    
    When undo changesets are transferred from buffer-undo-list to
    buffer-undo-tree, any markers are moved into a weak hash table, and replaced
    in the marker changeset element by a unique id that serves as the hash table
    key. When the changeset is copied for passing to primitive-undo, the reverse
    process replaces the id's by the corresponding markers from the hash
    table. However, if a marker has been garbage collected in the meantime, it
    will have been removed from the weak hash table, attempting to retrieve it
    will return null, and the corresponding marker changeset element will not be
    included in the copy of the changeset.
---
 undo-tree.el | 201 +++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 134 insertions(+), 67 deletions(-)

diff --git a/undo-tree.el b/undo-tree.el
index 2d9847b..c47119e 100644
--- a/undo-tree.el
+++ b/undo-tree.el
@@ -5,7 +5,7 @@
 ;; Copyright (C) 2009-2010 Toby Cubitt
 
 ;; Author: Toby Cubitt <toby-undo-tree@dr-qubit.org>
-;; Version: 0.1.7
+;; Version: 0.2
 ;; Keywords: undo, redo, history, tree
 ;; URL: http://www.dr-qubit.org/emacs.php
 ;; Git Repository: http://www.dr-qubit.org/git/undo-tree.git
@@ -468,22 +468,6 @@
 ;; Drawbacks
 ;; =========
 ;;
-;; Emacs' undo system is deeply embedded in Emacs. In particular, garbage
-;; collection treats the `buffer-undo-list' specially: references to markers
-;; in `buffer-undo-list' don't count during the mark phase, and the sweep
-;; phase removes undo entries for markers that have been garbage-collected.
-;; This behaviour is implemented in C as part of the garbage collection code,
-;; and it is difficult or impossible to emulate in Elisp.
-;;
-;; To avoid dead markers being resurrected in `undo-tree-mode', and to allow
-;; them to be garbage-collected, `undo-tree-mode' doesn't record marker
-;; adjustments. Markers are rarely explicitly created by users, so the impact
-;; of this will primarily be through its effects on other features that make
-;; use of markers. Since marker adjustments haven't always been restored by
-;; undo, and even then it was buggy until recently (see Emacs bug#4803), it
-;; seems likely that relatively little code relies heavily on correct marker
-;; restoration.
-;;
 ;; `undo-tree-mode' doesn't support "undo in region", i.e. selectively undoing
 ;; only the changes that affect the region. Support for this is planned for a
 ;; future version.
@@ -491,6 +475,9 @@
 
 
 ;;; Change Log:
+;; Version 0.2
+;; * added support for marker undo entries
+;;
 ;; Version 0.1.7
 ;; * pass null argument to `kill-buffer' call in `undo-tree-visualizer-quit',
 ;;   since the argument's not optional in earlier Emacs versions
@@ -729,9 +716,10 @@ in visualizer."
                  (&aux
                   (root (make-undo-tree-node nil nil))
                   (current root)
-                  (size 0)))
+                  (size 0)
+                 (object-pool (make-hash-table :test 'eq :weakness 'value))))
    (:copier nil))
-  root current size)
+  root current size object-pool)
 
 
 
@@ -865,6 +853,8 @@ Comparison is done with 'eq."
 
 
 (defvar *undo-tree-id-counter* 0)
+(make-variable-buffer-local '*undo-tree-id-counter*)
+
 (defmacro undo-tree-generate-id ()
   ;; Generate a new, unique id (uninterned symbol).
   ;; The name is made by appending a number to "undo-tree-id".
@@ -876,28 +866,92 @@ Comparison is done with 'eq."
 
 
 ;;; =====================================================================
-;;;         Utility functions for handling `buffer-undo-list'
+;;;    Utility functions for handling `buffer-undo-list' and changesets
+
+(defmacro undo-list-marker-elt-p (elt)
+  `(markerp (car-safe ,elt)))
+
+(defmacro undo-list-GCd-marker-elt-p (elt)
+  `(and (symbolp (car-safe ,elt)) (numberp (cdr-safe ,elt))))
+
+
+(defun undo-tree-move-GC-elts-to-pool (elt)
+  ;; Move elements that can be garbage-collected into `buffer-undo-tree'
+  ;; object pool, substituting a unique id that can be used to retrieve them
+  ;; later. (Only markers require this treatment currently.)
+  (when (undo-list-marker-elt-p elt)
+    (let ((id (undo-tree-generate-id)))
+      (puthash id (car elt) (undo-tree-object-pool buffer-undo-tree))
+      (setcar elt id))))
+
+
+(defun undo-tree-restore-GC-elts-from-pool (elt)
+  ;; Replace object id's in ELT with corresponding objects from
+  ;; `buffer-undo-tree' object pool and return modified ELT, or return nil if
+  ;; any object in ELT has been garbage-collected.
+  (if (undo-list-GCd-marker-elt-p elt)
+      (when (setcar elt (gethash (car elt)
+                                (undo-tree-object-pool buffer-undo-tree)))
+       elt)
+    elt))
+
+
+(defun undo-list-clean-GCd-elts (undo-list)
+  ;; Remove object id's from UNDO-LIST that refer to elements that have been
+  ;; garbage-collected. UNDO-LIST is modified by side-effect.
+  (while (undo-list-GCd-marker-elt-p (car undo-list))
+    (unless (gethash (caar undo-list)
+                    (undo-tree-object-pool buffer-undo-tree))
+      (setq undo-list (cdr undo-list))))
+  (let ((p undo-list))
+    (while (cdr p)
+      (when (and (undo-list-GCd-marker-elt-p (cadr p))
+                (null (gethash (car (cadr p))
+                               (undo-tree-object-pool buffer-undo-tree))))
+       (setcdr p (cddr p)))
+      (setq p (cdr p))))
+  undo-list)
+
 
 (defun undo-list-pop-changeset ()
   ;; Pop changeset from `buffer-undo-list'.
-  ;; discard undo boundaries and marker adjustment entries at head of list
-  (while (or (null (car buffer-undo-list))
-            (and (consp (car buffer-undo-list))
-                 (markerp (caar buffer-undo-list))))
+  ;; discard undo boundaries at head of list
+  (while (null (car buffer-undo-list))
     (setq buffer-undo-list (cdr buffer-undo-list)))
   ;; pop elements up to next undo boundary
   (unless (eq (car buffer-undo-list) 'undo-tree-canary)
-    (let* ((changeset (cons (pop buffer-undo-list) nil))
+    (let* ((changeset (list (pop buffer-undo-list)))
            (p changeset))
-      (while (car buffer-undo-list)
-        (setcdr p (cons (pop buffer-undo-list) nil))
-       ;; discard marker adjustment entries (see Commentary, above)
-       (if (and (consp (cadr p)) (markerp (car (cadr p))))
-           (setcdr p nil)
-         (setq p (cdr p))))
+      (while (progn
+              (undo-tree-move-GC-elts-to-pool (car p))
+              (car buffer-undo-list))
+        (setcdr p (list (pop buffer-undo-list)))
+       (setq p (cdr p)))
       changeset)))
 
 
+(defun undo-tree-copy-list (undo-list)
+  ;; Return a deep copy of first changeset in `undo-list'. Object id's are
+  ;; replaced by corresponding objects from `buffer-undo-tree' object-pool.
+  (when undo-list
+    (let (copy p)
+      ;; if first element contains an object id, replace it with object from
+      ;; pool, discarding element entirely if it's been GC'd
+      (while (null copy)
+       (setq copy
+             (undo-tree-restore-GC-elts-from-pool (pop undo-list))))
+      (setq copy (list copy)
+           p copy)
+      ;; copy remaining elements, replacing object id's with objects from
+      ;; pool, or discarding them entirely if they've been GC'd
+      (while undo-list
+       (when (setcdr p (undo-tree-restore-GC-elts-from-pool
+                        (undo-copy-list-1 (pop undo-list))))
+         (setcdr p (list (cdr p)))
+         (setq p (cdr p))))
+      copy)))
+
+
 
 (defun undo-list-transfer-to-tree ()
   ;; Transfer entries accumulated in `buffer-undo-list' to `buffer-undo-tree'.
@@ -1264,7 +1318,8 @@ Within the undo-tree visualizer, the following keys are 
available:
   ;; throw error if undo is disabled in buffer
   (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
 
-  (let ((undo-in-progress t))
+  (let ((undo-in-progress t)
+       current)
     ;; if `buffer-undo-tree' is empty, create initial undo-tree
     (when (null buffer-undo-tree)
       (setq buffer-undo-tree (make-undo-tree)))
@@ -1273,29 +1328,33 @@ Within the undo-tree visualizer, the following keys are 
available:
     (undo-list-transfer-to-tree)
 
     (dotimes (i (or arg 1))
+      (setq current (undo-tree-current buffer-undo-tree))
       ;; check if at top of undo tree
       (if (null (undo-tree-node-previous
                  (undo-tree-current buffer-undo-tree)))
           (error "No further undo information")
+       ;; remove any GC'd elements from node's undo list
+       (setq current (undo-tree-current buffer-undo-tree))
+       (decf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-undo current)))
+       (setf (undo-tree-node-undo current)
+             (undo-list-clean-GCd-elts (undo-tree-node-undo current)))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-undo current)))
         ;; undo one record from undo tree
-        (primitive-undo 1 (undo-copy-list
-                           (undo-tree-node-undo
-                            (undo-tree-current buffer-undo-tree))))
+        (primitive-undo 1 (undo-tree-copy-list (undo-tree-node-undo current)))
         ;; pop redo entries that `primitive-undo' has added to
         ;; `buffer-undo-list' and record them in current node's redo record,
        ;; replacing existing entry if one already exists
-        (when (undo-tree-node-redo (undo-tree-current buffer-undo-tree))
+        (when (undo-tree-node-redo current)
          (decf (undo-tree-size buffer-undo-tree)
-               (undo-list-byte-size
-                (undo-tree-node-redo (undo-tree-current buffer-undo-tree)))))
-       (setf (undo-tree-node-redo (undo-tree-current buffer-undo-tree))
-             (undo-list-pop-changeset))
+               (undo-list-byte-size (undo-tree-node-redo current))))
+       (setf (undo-tree-node-redo current) (undo-list-pop-changeset))
        (incf (undo-tree-size buffer-undo-tree)
-             (undo-list-byte-size
-              (undo-tree-node-redo (undo-tree-current buffer-undo-tree))))
+             (undo-list-byte-size (undo-tree-node-redo current)))
         ;; rewind current node
         (setf (undo-tree-current buffer-undo-tree)
-              (undo-tree-node-previous (undo-tree-current buffer-undo-tree)))
+             (undo-tree-node-previous current))
         ;; update timestamp
         (setf (undo-tree-node-timestamp (undo-tree-current buffer-undo-tree))
               (current-time))))
@@ -1311,7 +1370,8 @@ Within the undo-tree visualizer, the following keys are 
available:
   ;; throw error if undo is disabled in buffer
   (when (eq buffer-undo-list t) (error "No undo information in this buffer"))
 
-  (let ((undo-in-progress t))
+  (let ((undo-in-progress t)
+       current)
     ;; if `buffer-undo-tree' is empty, create initial undo-tree
     (when (null buffer-undo-tree)
       (setq buffer-undo-tree (make-undo-tree)))
@@ -1319,29 +1379,36 @@ Within the undo-tree visualizer, the following keys are 
available:
     ;; `buffer-undo-tree'
     (undo-list-transfer-to-tree)
 
-    (let ((current (undo-tree-current buffer-undo-tree)))
-      (dotimes (i (or arg 1))
-        ;; check if at bottom of undo tree
-        (if (null (undo-tree-node-next current))
-            (error "No further redo information")
-          ;; advance current node
-          (setq current
-                (setf (undo-tree-current buffer-undo-tree)
-                      (nth (undo-tree-node-branch current)
-                           (undo-tree-node-next current))))
-          ;; update timestamp
-          (setf (undo-tree-node-timestamp current) (current-time))
-          ;; redo one record from undo tree
-          (primitive-undo 1 (undo-copy-list (undo-tree-node-redo current)))
-         ;; pop undo entries that `primitive-undo' has added to
-         ;; `buffer-undo-list' and record them in current node's undo record,
-         ;; replacing existing entry if one already exists
-         (when (undo-tree-node-undo current)
-           (decf (undo-tree-size buffer-undo-tree)
-                 (undo-list-byte-size (undo-tree-node-undo current))))
-         (setf (undo-tree-node-undo current) (undo-list-pop-changeset))
-         (incf (undo-tree-size buffer-undo-tree)
-               (undo-list-byte-size (undo-tree-node-undo current))))))
+    (dotimes (i (or arg 1))
+      ;; check if at bottom of undo tree
+      (if (null (undo-tree-node-next (undo-tree-current buffer-undo-tree)))
+         (error "No further redo information")
+       ;; advance current node
+       (setq current (undo-tree-current buffer-undo-tree)
+             current (setf (undo-tree-current buffer-undo-tree)
+                           (nth (undo-tree-node-branch current)
+                                (undo-tree-node-next current))))
+       ;; remove any GC'd elements from node's redo list
+       (decf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-redo current)))
+       (setf (undo-tree-node-redo current)
+             (undo-list-clean-GCd-elts (undo-tree-node-redo current)))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-redo current)))
+       ;; redo one record from undo tree
+       (primitive-undo 1 (undo-tree-copy-list
+                          (undo-tree-node-redo current)))
+       ;; pop undo entries that `primitive-undo' has added to
+       ;; `buffer-undo-list' and record them in current node's undo record,
+       ;; replacing existing entry if one already exists
+       (when (undo-tree-node-undo current)
+         (decf (undo-tree-size buffer-undo-tree)
+               (undo-list-byte-size (undo-tree-node-undo current))))
+       (setf (undo-tree-node-undo current) (undo-list-pop-changeset))
+       (incf (undo-tree-size buffer-undo-tree)
+             (undo-list-byte-size (undo-tree-node-undo current)))
+       ;; update timestamp
+       (setf (undo-tree-node-timestamp current) (current-time))))
 
     ;; inform user if at branch point
     (when (> (undo-tree-num-branches) 1) (message "Undo branch point!"))))