From 621351bade1b4c5c25e37b3ee51fe604e561e8ae Mon Sep 17 00:00:00 2001 From: Radon Rosborough Date: Mon, 25 May 2020 10:58:49 -0600 Subject: [#15] Attempt to stop wrecking undo history --- CHANGELOG.md | 5 ++ apheleia.el | 240 ++++++++++++++++++++++++++++++++--------------------------- 2 files changed, 134 insertions(+), 111 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 230416f..d8b01f4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,9 +13,14 @@ The format is based on [Keep a Changelog]. * Previously, enabling `undo-tree-auto-save-history` caused Apheleia to mark the buffer as modified after formatting. This has been fixed ([#10]). +* Under some circumstances Apheleia would cause the buffer's undo + history to be lost. An attempt has been made to fix this, although + it's not obvious how to reproduce the problem so the fix has not + been verified ([#15]). [#8]: https://github.com/raxod502/apheleia/issues/8 [#10]: https://github.com/raxod502/apheleia/issues/10 +[#15]: https://github.com/raxod502/apheleia/issues/15 ## 1.1 (released 2020-04-02) ### Enhancements diff --git a/apheleia.el b/apheleia.el index 0d1b442..2ddbc77 100644 --- a/apheleia.el +++ b/apheleia.el @@ -132,120 +132,134 @@ regions will still be applied, but Apheleia won't try to move point correctly." :type 'integer) +(defmacro apheleia--with-single-undo (&rest body) + "Execute BODY as a single undo step." + (declare (indent 0)) + `(unwind-protect + (progn + (when (car-safe buffer-undo-list) + (undo-boundary)) + (let ((buffer-undo-list t)) + ,@body)) + (when (car-safe buffer-undo-list) + (undo-boundary)))) + (defun apheleia--apply-rcs-patch (content-buffer patch-buffer) "Apply RCS patch. CONTENT-BUFFER contains the text to be patched, and PATCH-BUFFER contains the patch." - (let ((commands nil) - (point-list nil) - (window-line-list nil)) - (with-current-buffer content-buffer - (push (cons nil (point)) point-list) - (dolist (w (get-buffer-window-list nil nil t)) - (push (cons w (window-point w)) point-list) - (push (cons w (count-lines (window-start w) (point))) - window-line-list))) - (with-current-buffer patch-buffer - (apheleia--map-rcs-patch - (lambda (command) - (with-current-buffer content-buffer - ;; Could be optimized significantly by moving only as many - ;; lines as needed, rather than returning to the beginning - ;; of the buffer first. - (save-excursion - (goto-char (point-min)) - (forward-line (1- (alist-get 'start command))) - ;; Account for the off-by-one error in the RCS patch spec - ;; (namely, text is added *after* the line mentioned in - ;; the patch). - (when (eq (alist-get 'command command) 'addition) - (forward-line)) - (push `(marker . ,(point-marker)) command) - (push command commands) - ;; If we delete a region just before inserting new text - ;; at the same place, then it is a replacement. In this - ;; case, check if the replaced region includes the window - ;; point for any window currently displaying the content - ;; buffer. If so, figure out where that window point - ;; should be moved to, and record the information in an - ;; additional command. - ;; - ;; See . - ;; - ;; Note that the commands get pushed in reverse order - ;; because of how linked lists work. - (let ((deletion (nth 1 commands)) - (addition (nth 0 commands))) - (when (and (eq (alist-get 'command deletion) 'deletion) - (eq (alist-get 'command addition) 'addition) - ;; Again with the weird off-by-one - ;; computations. For example, if you replace - ;; lines 68 through 71 inclusive, then the - ;; deletion is for line 68 and the addition - ;; is for line 70. Blame RCS. - (= (+ (alist-get 'start deletion) - (alist-get 'lines deletion) - -1) - (alist-get 'start addition))) - (let ((text-start (alist-get 'marker deletion))) - (forward-line (alist-get 'lines deletion)) - (let ((text-end (point))) - (dolist (entry point-list) - ;; Check if the (window) point is within the - ;; replaced region. - (cl-destructuring-bind (w . p) entry - (when (and (< text-start p) - (< p text-end)) - (let* ((old-text (buffer-substring-no-properties - text-start text-end)) - (new-text (alist-get 'text addition)) - (old-relative-point (- p text-start)) - (new-relative-point - (if (> (max (length old-text) - (length new-text)) - apheleia-max-alignment-size) - old-relative-point - (apheleia--align-point - old-text new-text old-relative-point)))) - (goto-char text-start) - (push `((marker . ,(point-marker)) - (command . set-point) - (window . ,w) - (relative-point . ,new-relative-point)) - commands)))))))))))))) - (with-current-buffer content-buffer - (let ((move-to nil)) - (save-excursion - (dolist (command (nreverse commands)) - (goto-char (alist-get 'marker command)) - (pcase (alist-get 'command command) - (`addition - (insert (alist-get 'text command))) - (`deletion - (let ((text-start (point))) - (forward-line (alist-get 'lines command)) - (delete-region text-start (point)))) - (`set-point - (let ((new-point - (+ (point) (alist-get 'relative-point command)))) - (if-let ((w (alist-get 'window command))) - (set-window-point w new-point) - (setq move-to new-point))))))) - (when move-to - (goto-char move-to)))) - ;; Restore the scroll position of each window displaying the - ;; buffer. - (dolist (entry window-line-list) - (cl-destructuring-bind (w . old-window-line) entry - (let ((new-window-line - (count-lines (window-start w) (point)))) - (with-selected-window w - ;; Sometimes if the text is less than a buffer long, and - ;; we do a deletion, it might not be possible to keep the - ;; vertical position of point the same by scrolling. - ;; That's okay. We just go as far as we can. - (ignore-errors - (scroll-down (- old-window-line new-window-line))))))))) + (apheleia--with-single-undo + (let ((commands nil) + (point-list nil) + (window-line-list nil)) + (with-current-buffer content-buffer + (push (cons nil (point)) point-list) + (dolist (w (get-buffer-window-list nil nil t)) + (push (cons w (window-point w)) point-list) + (push (cons w (count-lines (window-start w) (point))) + window-line-list))) + (with-current-buffer patch-buffer + (apheleia--map-rcs-patch + (lambda (command) + (with-current-buffer content-buffer + ;; Could be optimized significantly by moving only as many + ;; lines as needed, rather than returning to the beginning + ;; of the buffer first. + (save-excursion + (goto-char (point-min)) + (forward-line (1- (alist-get 'start command))) + ;; Account for the off-by-one error in the RCS patch spec + ;; (namely, text is added *after* the line mentioned in + ;; the patch). + (when (eq (alist-get 'command command) 'addition) + (forward-line)) + (push `(marker . ,(point-marker)) command) + (push command commands) + ;; If we delete a region just before inserting new text + ;; at the same place, then it is a replacement. In this + ;; case, check if the replaced region includes the window + ;; point for any window currently displaying the content + ;; buffer. If so, figure out where that window point + ;; should be moved to, and record the information in an + ;; additional command. + ;; + ;; See . + ;; + ;; Note that the commands get pushed in reverse order + ;; because of how linked lists work. + (let ((deletion (nth 1 commands)) + (addition (nth 0 commands))) + (when (and (eq (alist-get 'command deletion) 'deletion) + (eq (alist-get 'command addition) 'addition) + ;; Again with the weird off-by-one + ;; computations. For example, if you replace + ;; lines 68 through 71 inclusive, then the + ;; deletion is for line 68 and the addition + ;; is for line 70. Blame RCS. + (= (+ (alist-get 'start deletion) + (alist-get 'lines deletion) + -1) + (alist-get 'start addition))) + (let ((text-start (alist-get 'marker deletion))) + (forward-line (alist-get 'lines deletion)) + (let ((text-end (point))) + (dolist (entry point-list) + ;; Check if the (window) point is within the + ;; replaced region. + (cl-destructuring-bind (w . p) entry + (when (and (< text-start p) + (< p text-end)) + (let* ((old-text (buffer-substring-no-properties + text-start text-end)) + (new-text (alist-get 'text addition)) + (old-relative-point (- p text-start)) + (new-relative-point + (if (> (max (length old-text) + (length new-text)) + apheleia-max-alignment-size) + old-relative-point + (apheleia--align-point + old-text new-text + old-relative-point)))) + (goto-char text-start) + (push `((marker . ,(point-marker)) + (command . set-point) + (window . ,w) + (relative-point . ,new-relative-point)) + commands)))))))))))))) + (with-current-buffer content-buffer + (let ((move-to nil)) + (save-excursion + (dolist (command (nreverse commands)) + (goto-char (alist-get 'marker command)) + (pcase (alist-get 'command command) + (`addition + (insert (alist-get 'text command))) + (`deletion + (let ((text-start (point))) + (forward-line (alist-get 'lines command)) + (delete-region text-start (point)))) + (`set-point + (let ((new-point + (+ (point) (alist-get 'relative-point command)))) + (if-let ((w (alist-get 'window command))) + (set-window-point w new-point) + (setq move-to new-point))))))) + (when move-to + (goto-char move-to)))) + ;; Restore the scroll position of each window displaying the + ;; buffer. + (dolist (entry window-line-list) + (cl-destructuring-bind (w . old-window-line) entry + (let ((new-window-line + (count-lines (window-start w) (point)))) + (with-selected-window w + ;; Sometimes if the text is less than a buffer long, and + ;; we do a deletion, it might not be possible to keep the + ;; vertical position of point the same by scrolling. + ;; That's okay. We just go as far as we can. + (ignore-errors + (scroll-down (- old-window-line new-window-line)))))))))) (defvar apheleia--current-process nil "Current process that Apheleia is running, or nil. @@ -606,7 +620,11 @@ changes), CALLBACK, if provided, is invoked with no arguments." (lambda (formatted-buffer) (with-current-buffer cur-buffer ;; Short-circuit. - (when (equal apheleia--buffer-hash (apheleia--buffer-hash)) + (when (and (equal apheleia--buffer-hash (apheleia--buffer-hash)) + (not + (equal apheleia--buffer-hash + (with-current-buffer formatted-buffer + (apheleia--buffer-hash))))) (apheleia--create-rcs-patch (current-buffer) formatted-buffer (lambda (patch-buffer) -- cgit v1.0