undo-tree -- history file without text-properties

Question

Q:  How can I modify undo-tree-save-history to remove the text-properties from all entries that make their way into the saved history file?

In a related thread, @PythonNut was on a very similar quest to remove text-properties from entries that make their way into the history file created by undo-tree-save-history: text-properties bloat persistent undo files

In that related thread, the original poster chose to remove text-properties before they ever become part of the buffer-undo-tree. This is not ideal, in my opinion, because a user should be able to undo/redo entries with text-properties intact if so desired. I am looking for a solution that does not modify either buffer-undo-tree or buffer-undo-list -- instead, I only want a history file without text-properties.

Answer 1

The following is a modified version of undo-tree-save-history. As the code in the first version of your question I don't write to a file but output the undo tree as a string. I hope that is okay.

The most important changes w.r.t. undo-tree-save-history are:

1. a recursive copy of the undo tree via (copy-tree buffer-undo-tree t) to avoid effects on the original buffer-undo-tree
2. a deep recursion into the tree copy removing text properties on strings via undo-tree-seq-unprop

(require 'seq)
(require 'cl-lib)

(cl-defstruct (copy-tree*
               (:constructor copy-tree*-mem (&optional stack stack-new (hash (make-hash-table)))))
  stack stack-new hash)

(defmacro copy-tree*--push (el el-new mem &optional hash)
  (let ((my-el (make-symbol "my-el"))
        (my-el-new (make-symbol "my-el-new"))) ; makes sure `el' is only evaluated once
    (append `(let ((,my-el ,el)
                   (,my-el-new ,el-new))
               (push ,my-el (copy-tree*-stack ,mem))
               (push ,my-el-new (copy-tree*-stack-new ,mem)))
            (and hash
                 `((puthash ,my-el ,my-el-new (copy-tree*-hash ,mem))))
            (list my-el-new))))

(defmacro copy-tree*--pop (el el-new mem)
  `(setq ,el (pop (copy-tree*-stack ,mem))
         ,el-new (pop (copy-tree*-stack-new mem))))

(defun copy-tree*--copy-node (node mem vecp)
  (if (or (consp node)
      (and vecp (vectorp node)))
      (let ((existing-node (gethash node (copy-tree*-hash mem))))
    (if existing-node
        existing-node
      (copy-tree*--push node (if (consp node)
                     (cons nil nil)
                   (make-vector (length node) nil))
                mem t)))
    node))

(defun copy-tree* (tree &optional vecp)
  "Structure preserving version of `cl-copy-tree'."
  (if (or (consp tree)
      (and vecp (vectorp tree)))
      (let* ((tree-new (if (consp tree) (cons nil nil)
             (make-vector (length tree) nil)))
             (mem (copy-tree*-mem))
             next
             next-new)
        (copy-tree*--push tree tree-new mem t)
        (while (copy-tree*--pop next next-new mem)
      (cond
       ((consp next)
        (setcar next-new (copy-tree*--copy-node (car next) mem vecp))
        (setcdr next-new (copy-tree*--copy-node (cdr next) mem vecp)))
       ((and vecp (vectorp next))
        (cl-loop for i from 0 below (length next) do
             (aset next-new i (copy-tree*--copy-node (aref next i) mem vecp))))))
    tree-new)
    tree))


(defun undo-tree-seq-unprop (x)
  "Remove text properties on all strings of seq."
  (cond
   ((stringp x)
    (substring-no-properties x))
   ((consp x)
    (cons (undo-tree-seq-unprop (car x)) (undo-tree-seq-unprop (cdr x))))
   ((null x)
    nil)
   ((seqp x)
    (apply (type-of x) (seq-map (lambda (x) (undo-tree-seq-unprop x)) x)))
   (t x)))

(defun undo-tree-string (&optional filename)
  "Return undo-tree as a string.
If FILENAME is a string save this string in file with name FILENAME.
Ask for the file name in the interactive case."
  (interactive "FFile name: ") ;; just to ease testing
  (when (eq buffer-undo-list t)
    (user-error "No undo information in this buffer"))
  (undo-list-transfer-to-tree)
  (when (and buffer-undo-tree (not (eq buffer-undo-tree t)))
    (condition-case nil
    (progn
      (undo-tree-clear-visualizer-data buffer-undo-tree)
      (undo-tree-kill-visualizer))
      (error (undo-tree-clear-visualizer-data buffer-undo-tree)))
    (let ((buff (current-buffer))
          tree
          return-string)
      (unwind-protect
          (progn
            ;; transform undo-tree into non-circular structure, and make
            ;; temporary copy
            (undo-tree-decircle buffer-undo-tree)
        (setq tree (copy-tree* buffer-undo-tree t))
            ;; discard undo-tree object pool before saving
            (setf (undo-tree-object-pool tree) nil)
        (undo-tree-mapc (lambda (node)
                  (setf (undo-tree-node-undo node) (undo-tree-seq-unprop (undo-tree-node-undo node)))
                  (setf (undo-tree-node-redo node) (undo-tree-seq-unprop (undo-tree-node-redo node)))
                  )
                (undo-tree-root tree))
            (with-auto-compression-mode
              (with-temp-buffer
                (prin1 (sha1 buff) (current-buffer))
                (terpri (current-buffer))
                (let ((print-circle t)) (prin1 tree (current-buffer)))
                (setq return-string (buffer-string))
        (when filename
          (write-file filename)))))
        ;; restore circular undo-tree data structure
        (undo-tree-recircle buffer-undo-tree))
      return-string)))

EDITS:

1. I added copy-tree* as a structure-preserving version of copy-tree. Therewith, undo-tree-string should work but it is only tested for a few cases.
2. User lawlist has detected an error with killing the visualizer. I just put in his solution to call undo-tree-clear-visualizer-data buffer-undo-tree before undo-tree-kill-visualizer. Hopefully, the code works much better now thanks to lawlist!