From 4fd5a97052472eb1c332ea9b3f9ff90e94ad0cd1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 5 Apr 2024 17:37:32 -0400 Subject: [PATCH] lisp/emacs-lisp/track-changes.el: New file This new package provides an API that is easier to use right than our `*-change-functions` hooks. The patch includes changes to `diff-mode.el` and `eglot.el` to make use of this new package. * lisp/emacs-lisp/track-changes.el: New file. * test/lisp/emacs-lisp/track-changes-tests.el: New file. * lisp/progmodes/eglot.el: Require `track-changes`. (eglot--virtual-pos-to-lsp-position): New function. (eglot--track-changes): New var. (eglot--managed-mode): Use `track-changes-register` i.s.o `after/before-change-functions`. (eglot--before-change): Delete function. (eglot--track-changes-signal): Rename from `eglot--after-change` and adjust arguments accordingly. (eglot--track-changes-fetch): New function. (eglot--signal-textDocument/didChange): Call it and simplify now that corner-cases are handled by `track-changes`. * lisp/vc/diff-mode.el: Require `track-changes`. Also require `easy-mmode` before the `eval-when-compile`s. (diff-unhandled-changes): Delete variable. (diff-after-change-function): Delete function. (diff--track-changes-function): Rename from `diff-post-command-hook` and adjust to new calling convention. (diff--track-changes): New variable. (diff--track-changes-signal): New function. (diff-mode, diff-minor-mode): Use it with `track-changes-register`. --- lisp/emacs-lisp/track-changes.el | 605 ++++++++++++++++++++ lisp/progmodes/eglot.el | 105 ++-- lisp/vc/diff-mode.el | 107 ++-- test/lisp/emacs-lisp/track-changes-tests.el | 149 +++++ 4 files changed, 852 insertions(+), 114 deletions(-) create mode 100644 lisp/emacs-lisp/track-changes.el create mode 100644 test/lisp/emacs-lisp/track-changes-tests.el diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el new file mode 100644 index 00000000000..7644a7de98d --- /dev/null +++ b/lisp/emacs-lisp/track-changes.el @@ -0,0 +1,605 @@ +;;; track-changes.el --- API to react to buffer modifications -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; Author: Stefan Monnier + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This library is a layer of abstraction above `before-change-functions' +;; and `after-change-functions' which takes care of accumulating changes +;; until a time when its client finds it convenient to react to them. +;; +;; It provides an API that is easier to use correctly than our +;; `*-change-functions` hooks. Problems that it claims to solve: +;; +;; - Before and after calls are not necessarily paired. +;; - The beg/end values don't always match. +;; - There's usually only one call to the hooks per command but +;; there can be thousands of calls from within a single command, +;; so naive users will tend to write code that performs poorly +;; in those rare cases. +;; - The hooks are run at a fairly low-level so there are things they +;; really shouldn't do, such as modify the buffer or wait. +;; - The after call doesn't get enough info to rebuild the before-change state, +;; so some callers need to use both before-c-f and after-c-f (and then +;; deal with the first two points above). +;; +;; The new API is almost like `after-change-functions` except that: +;; - It provides the "before string" (i.e. the previous content of +;; the changed area) rather than only its length. +;; - It can combine several changes into larger ones. +;; - Clients do not have to process changes right away, instead they +;; can let changes accumulate (by combining them into a larger change) +;; until it is convenient for them to process them. +;; - By default, changes are signaled at most once per command. + +;; The API consists in the following functions: +;; +;; (track-changes-register SIGNAL &key NOBEFORE DISJOINT IMMEDIATE) +;; (track-changes-fetch ID FUNC) +;; (track-changes-unregister ID) +;; +;; A typical use case might look like: +;; +;; (defvar my-foo--change-tracker nil) +;; (define-minor-mode my-foo-mode +;; "Fooing like there's no tomorrow." +;; (if (null my-foo-mode) +;; (when my-foo--change-tracker +;; (track-changes-unregister my-foo--change-tracker) +;; (setq my-foo--change-tracker nil)) +;; (unless my-foo--change-tracker +;; (setq my-foo--change-tracker +;; (track-changes-register +;; (lambda (id) +;; (track-changes-fetch +;; id (lambda (beg end before) +;; ..DO THE THING..)))))))) + +;;; Code: + +(require 'cl-lib) + +(unless (fboundp 'funcall-later) + (defun funcall-later (&rest args) + ;; FIXME: Not sure if `run-with-timer' preserves ordering between + ;; different calls with the same target time. + (apply #'run-with-timer 0 nil args))) + +;;;; Internal types and variables. + +(cl-defstruct (track-changes--tracker + (:noinline t) + (:constructor nil) + (:constructor track-changes--tracker ( signal state + &optional + nobefore immediate))) + signal state nobefore immediate) + +(cl-defstruct (track-changes--state + (:noinline t) + (:constructor nil) + (:constructor track-changes--state ())) + "Object holding a description of a buffer state. +BEG..END is the area that was changed and BEFORE is its previous content. +If the current buffer currently holds the content of the next state, you can get +the contents of the previous state with: + + (concat (buffer-substring (point-min) beg) + before + (buffer-substring end (point-max))) + +NEXT is the next state object (i.e. a more recent state). +If NEXT is nil it means it's most recent state and it may be incomplete +\(BEG/END/BEFORE may be nil), in which case those fields will take their +values from `track-changes--before-(beg|end|before)' when the next +state is create." + (beg (point-max)) + (end (point-min)) + (before nil) + (next nil)) + +(defvar-local track-changes--trackers () + "List of trackers currently registered in the current buffer.") +(defvar-local track-changes--clean-trackers () + "List of trackers that are clean. +Those are the trackers that get signaled when a change is made.") + +(defvar-local track-changes--disjoint-trackers () + "List of trackers that want to react to disjoint changes. +These trackers' are signaled every time track-changes notices +that some upcoming changes touch another \"distant\" part of the buffer.") + +(defvar-local track-changes--state nil) + +;; `track-changes--before-*' keep track of the content of the +;; buffer when `track-changes--state' was cleaned. +(defvar-local track-changes--before-beg (point-min) + "Beginning position of the remembered \"before string\".") +(defvar-local track-changes--before-end (point-min) + "End position of the text replacing the \"before string\".") +(defvar-local track-changes--before-string "" + "String holding some contents of the buffer before the current change. +This string is supposed to cover all the already modified areas plus +the upcoming modifications announced via `before-change-functions'. +If all trackers are `nobefore', then this holds the `buffer-size' before +the current change.") +(defvar-local track-changes--before-no t + "If non-nil, all the trackers are `nobefore'. +Should be equal to (memq #\\='track-changes--before before-change-functions).") + +(defvar-local track-changes--before-clean 'unset + "If non-nil, the `track-changes--before-*' vars are old. +More specifically it means they cover a part of the buffer relevant +for the previous state. +It can take two non-nil values: +- `unset': Means that the vars cover some older state. + This is what it is set right after creating a fresh new state. +- `set': Means the vars reflect the current buffer state. + This is what it is set to after the first `before-change-functions' + but before an `after-change-functions'.") + +(defvar-local track-changes--buffer-size nil + "Current size of the buffer, as far as this library knows. +This is used to try and detect cases where buffer modifications are \"lost\".") + +;;;; Exposed API. + +(cl-defun track-changes-register ( signal &key nobefore disjoint immediate) + "Register a new tracker and return a new tracker ID. +SIGNAL is a function that will be called with one argument (the tracker ID) +after the current buffer is modified, so that we can react to the change. +Once called, SIGNAL is not called again until `track-changes-fetch' +is called with the corresponding tracker ID. + +If optional argument NOBEFORE is non-nil, it means that this tracker does +not need the BEFORE strings (it will receive their size instead). + +By default SIGNAL is called as soon as convenient after a change, which is +usually right after the end of the current command. +If optional argument IMMEDIATE is non-nil it means SIGNAL should be called +as soon as a change is detected, +BEWARE: In that case SIGNAL is called directly from `after-change-functions' +and should thus be extra careful: don't modify the buffer, don't call a function +that may block, do as little work as possible, ... +When IMMEDIATE is non-nil, the SIGNAL should preferably not always call +`track-changes-fetch', since that would defeat the purpose of this library. + +If optional argument DISJOINT is non-nil, SIGNAL is called every time we are +about to combine changes from \"distant\" parts of the buffer. +This is needed when combining disjoint changes into one bigger change +is unacceptable, typically for performance reasons. +These calls are distinguished from normal calls by calling SIGNAL with +a second argument which is the distance between the upcoming change and +the previous changes. +BEWARE: In that case SIGNAL is called directly from `before-change-functions' +and should thus be extra careful: don't modify the buffer, don't call a function +that may block, ... +In order to prevent the upcoming change from being combined with the previous +changes, SIGNAL needs to call `track-changes-fetch' before it returns." + (when (and nobefore disjoint) + ;; FIXME: Without `before-change-functions', we can only discover + ;; a disjoint change after the fact, which is not good enough. + ;; But we could use stripped down before-change-function, + (error "`disjoint' not supported for `nobefore' trackers")) + (track-changes--clean-state) + (unless nobefore + (setq track-changes--before-no nil) + (add-hook 'before-change-functions #'track-changes--before nil t)) + (add-hook 'after-change-functions #'track-changes--after nil t) + (let ((tracker (track-changes--tracker signal track-changes--state + nobefore immediate))) + (push tracker track-changes--trackers) + (push tracker track-changes--clean-trackers) + (when disjoint + (push tracker track-changes--disjoint-trackers)) + tracker)) + +(defun track-changes-unregister (id) + "Remove the tracker denoted by ID. +Trackers can consume resources (especially if `track-changes-fetch' is +not called), so it is good practice to unregister them when you don't +need them any more." + (unless (memq id track-changes--trackers) + (error "Unregistering a non-registered tracker: %S" id)) + (setq track-changes--trackers (delq id track-changes--trackers)) + (setq track-changes--clean-trackers (delq id track-changes--clean-trackers)) + (setq track-changes--disjoint-trackers + (delq id track-changes--disjoint-trackers)) + (when (cl-every #'track-changes--tracker-nobefore track-changes--trackers) + (setq track-changes--before-no t) + (remove-hook 'before-change-functions #'track-changes--before t)) + (when (null track-changes--trackers) + (mapc #'kill-local-variable + '(track-changes--before-beg + track-changes--before-end + track-changes--before-string + track-changes--buffer-size + track-changes--before-clean + track-changes--state)) + (remove-hook 'after-change-functions #'track-changes--after t))) + +(defun track-changes-fetch (id func) + "Fetch the pending changes. +ID is the tracker ID returned by a previous `track-changes-register'. +FUNC is a function. It is called with 3 arguments (BEGIN END BEFORE) +where BEGIN..END delimit the region that was changed since the last +time `track-changes-fetch' was called and BEFORE is a string containing +the previous content of that region (or just its length as an integer +If the tracker ID was registered with the `nobefore' option). +If some error caused us to miss some changes, then BEFORE will be the +symbol `error' to indicate that the buffer got out of sync. +This reflects a bug somewhere, so please report it when it happens. + +If no changes occurred since the last time, FUNC is not called and +we return nil, otherwise we return the value returned by FUNC, +and re-enable the TRACKER corresponding to ID." + (cl-assert (memq id track-changes--trackers)) + (unless (equal track-changes--buffer-size (buffer-size)) + (track-changes--recover-from-error)) + (let ((beg nil) + (end nil) + (before t) + (lenbefore 0) + (states ())) + ;; Transfer the data from `track-changes--before-string' + ;; to the tracker's state object, if needed. + (track-changes--clean-state) + ;; We want to combine the states from most recent to oldest, + ;; so reverse them. + (let ((state (track-changes--tracker-state id))) + (while state + (push state states) + (setq state (track-changes--state-next state)))) + + (cond + ((eq (car states) track-changes--state) + (cl-assert (null (track-changes--state-before (car states)))) + (setq states (cdr states))) + (t + ;; The states are disconnected from the latest state because + ;; we got out of sync! + (cl-assert (eq (track-changes--state-before (car states)) 'error)) + (setq beg (point-min)) + (setq end (point-max)) + (setq before 'error) + (setq states nil))) + + (dolist (state states) + (let ((prevbeg (track-changes--state-beg state)) + (prevend (track-changes--state-end state)) + (prevbefore (track-changes--state-before state))) + (if (eq before t) + (progn + ;; This is the most recent change. Just initialize the vars. + (setq beg prevbeg) + (setq end prevend) + (setq lenbefore + (if (stringp prevbefore) (length prevbefore) prevbefore)) + (setq before + (unless (track-changes--tracker-nobefore id) prevbefore))) + (let ((endb (+ beg lenbefore))) + (when (< prevbeg beg) + (if (not before) + (setq lenbefore (+ (- beg prevbeg) lenbefore)) + (setq before + (concat (buffer-substring-no-properties + prevbeg beg) + before)) + (setq lenbefore (length before))) + (setq beg prevbeg) + (cl-assert (= endb (+ beg lenbefore)))) + (when (< endb prevend) + (let ((new-end (+ end (- prevend endb)))) + (if (not before) + (setq lenbefore (+ lenbefore (- new-end end))) + (setq before + (concat before + (buffer-substring-no-properties + end new-end))) + (setq lenbefore (length before))) + (setq end new-end) + (cl-assert (= prevend (+ beg lenbefore))) + (setq endb (+ beg lenbefore)))) + (cl-assert (<= beg prevbeg prevend endb)) + ;; The `prevbefore' is covered by the new one. + (if (not before) + (setq lenbefore + (+ (- prevbeg beg) + (if (stringp prevbefore) + (length prevbefore) prevbefore) + (- endb prevend))) + (setq before + (concat (substring before 0 (- prevbeg beg)) + prevbefore + (substring before (- (length before) + (- endb prevend))))) + (setq lenbefore (length before))))))) + (if (null beg) + (progn + (cl-assert (null states)) + (cl-assert (memq id track-changes--clean-trackers)) + (cl-assert (eq (track-changes--tracker-state id) + track-changes--state)) + ;; Nothing to do. + nil) + (cl-assert (<= (point-min) beg end (point-max))) + ;; Update the tracker's state *before* running `func' so we don't risk + ;; mistakenly replaying the changes in case `func' exits non-locally. + (setf (track-changes--tracker-state id) track-changes--state) + (unwind-protect (funcall func beg end (or before lenbefore)) + ;; Re-enable the tracker's signal only after running `func', so + ;; as to avoid recursive invocations. + (cl-pushnew id track-changes--clean-trackers))))) + +;;;; Auxiliary functions. + +(defun track-changes--clean-state () + (cond + ((null track-changes--state) + (cl-assert track-changes--before-clean) + (cl-assert (null track-changes--buffer-size)) + ;; No state has been created yet. Do it now. + (setq track-changes--buffer-size (buffer-size)) + (when track-changes--before-no + (setq track-changes--before-string (buffer-size))) + (setq track-changes--state (track-changes--state))) + (track-changes--before-clean nil) + (t + (cl-assert (<= (track-changes--state-beg track-changes--state) + (track-changes--state-end track-changes--state))) + (let ((actual-beg (track-changes--state-beg track-changes--state)) + (actual-end (track-changes--state-end track-changes--state))) + (if track-changes--before-no + (progn + (cl-assert (integerp track-changes--before-string)) + (setf (track-changes--state-before track-changes--state) + (- track-changes--before-string + (- (buffer-size) (- actual-end actual-beg)))) + (setq track-changes--before-string (buffer-size))) + (cl-assert (<= track-changes--before-beg + actual-beg actual-end + track-changes--before-end)) + (cl-assert (null (track-changes--state-before track-changes--state))) + ;; The `track-changes--before-*' vars can cover more text than the + ;; actually modified area, so trim it down now to the relevant part. + (unless (= (- track-changes--before-end track-changes--before-beg) + (- actual-end actual-beg)) + (setq track-changes--before-string + (substring track-changes--before-string + (- actual-beg track-changes--before-beg) + (- (length track-changes--before-string) + (- track-changes--before-end actual-end)))) + (setq track-changes--before-beg actual-beg) + (setq track-changes--before-end actual-end)) + (setf (track-changes--state-before track-changes--state) + track-changes--before-string))) + ;; Note: We preserve `track-changes--before-*' because they may still + ;; be needed, in case `after-change-functions' are run before the next + ;; `before-change-functions'. + ;; Instead, we set `track-changes--before-clean' to `unset' to mean that + ;; `track-changes--before-*' can be reset at the next + ;; `before-change-functions'. + (setq track-changes--before-clean 'unset) + (let ((new (track-changes--state))) + (setf (track-changes--state-next track-changes--state) new) + (setq track-changes--state new))))) + +(defvar track-changes--disjoint-threshold 100 + "Distance below which changes are not considered disjoint.") + +(defvar track-changes--error-log () + "List of errors encountered. +Each element is a triplet (BUFFER-NAME BACKTRACE RECENT-KEYS).") + +(defun track-changes--recover-from-error () + ;; We somehow got out of sync. This is usually the result of a bug + ;; elsewhere that causes the before-c-f and after-c-f to be improperly + ;; paired, or to be skipped altogether. + ;; Not much we can do, other than force a full re-synchronization. + (warn "Missing/incorrect calls to `before/after-change-functions'!! +Details logged to `track-changes--error-log'") + (push (list (buffer-name) + (backtrace-frames 'track-changes--recover-from-error) + (recent-keys 'include-cmds)) + track-changes--error-log) + (setq track-changes--before-clean 'unset) + (setq track-changes--buffer-size (buffer-size)) + ;; Create a new state disconnected from the previous ones! + ;; Mark the previous one as junk, just to be clear. + (setf (track-changes--state-before track-changes--state) 'error) + (setq track-changes--state (track-changes--state))) + +(defun track-changes--before (beg end) + (cl-assert track-changes--state) + (cl-assert (<= beg end)) + (let* ((size (- end beg)) + (reset (lambda () + (cl-assert track-changes--before-clean) + (setq track-changes--before-clean 'set) + (setf track-changes--before-string + (buffer-substring-no-properties beg end)) + (setf track-changes--before-beg beg) + (setf track-changes--before-end end))) + + (signal-if-disjoint + (lambda (pos1 pos2) + (let ((distance (- pos2 pos1))) + (when (> distance + (max track-changes--disjoint-threshold + ;; If the distance is smaller than the size of the + ;; current change, then we may as well consider it + ;; as "near". + (length track-changes--before-string) + size + (- track-changes--before-end + track-changes--before-beg))) + (dolist (tracker track-changes--disjoint-trackers) + (funcall (track-changes--tracker-signal tracker) + tracker distance)) + ;; Return non-nil if the state was cleaned along the way. + track-changes--before-clean))))) + + (if track-changes--before-clean + (progn + ;; Detect disjointness with previous changes here as well, + ;; so that if a client calls `track-changes-fetch' all the time, + ;; it doesn't prevent others from getting a disjointness signal. + (when (and track-changes--before-beg + (let ((found nil)) + (dolist (tracker track-changes--disjoint-trackers) + (unless (memq tracker track-changes--clean-trackers) + (setq found t))) + found)) + ;; There's at least one `tracker' that wants to know about disjoint + ;; changes *and* it has unseen pending changes. + ;; FIXME: This can occasionally signal a tracker that's clean. + (if (< beg track-changes--before-beg) + (funcall signal-if-disjoint end track-changes--before-beg) + (funcall signal-if-disjoint track-changes--before-end beg))) + (funcall reset)) + (cl-assert (save-restriction + (widen) + (<= (point-min) + track-changes--before-beg + track-changes--before-end + (point-max)))) + (when (< beg track-changes--before-beg) + (if (and track-changes--disjoint-trackers + (funcall signal-if-disjoint end track-changes--before-beg)) + (funcall reset) + (let* ((old-bbeg track-changes--before-beg) + ;; To avoid O(Nē) behavior when faced with many small changes, + ;; we copy more than needed. + (new-bbeg (min (max (point-min) + (- old-bbeg + (length track-changes--before-string))) + beg))) + (setf track-changes--before-beg new-bbeg) + (cl-callf (lambda (old new) (concat new old)) + track-changes--before-string + (buffer-substring-no-properties new-bbeg old-bbeg))))) + + (when (< track-changes--before-end end) + (if (and track-changes--disjoint-trackers + (funcall signal-if-disjoint track-changes--before-end beg)) + (funcall reset) + (let* ((old-bend track-changes--before-end) + ;; To avoid O(Nē) behavior when faced with many small changes, + ;; we copy more than needed. + (new-bend (max (min (point-max) + (+ old-bend + (length track-changes--before-string))) + end))) + (setf track-changes--before-end new-bend) + (cl-callf concat track-changes--before-string + (buffer-substring-no-properties old-bend new-bend)))))))) + +(defun track-changes--after (beg end len) + (cl-assert track-changes--state) + (and (eq track-changes--before-clean 'unset) + (not track-changes--before-no) + ;; This can be a sign that a `before-change-functions' went missing, + ;; or that we called `track-changes--clean-state' between + ;; a `before-change-functions' and `after-change-functions'. + (track-changes--before beg end)) + (setq track-changes--before-clean nil) + (let ((offset (- (- end beg) len))) + (cl-incf track-changes--before-end offset) + (cl-incf track-changes--buffer-size offset) + (if (not (or track-changes--before-no + (save-restriction + (widen) + (<= (point-min) + track-changes--before-beg + beg end + track-changes--before-end + (point-max))))) + ;; BEG..END is not covered by previous `before-change-functions'!! + (track-changes--recover-from-error) + ;; Note the new changes. + (when (< beg (track-changes--state-beg track-changes--state)) + (setf (track-changes--state-beg track-changes--state) beg)) + (cl-callf (lambda (old-end) (max end (+ old-end offset))) + (track-changes--state-end track-changes--state)) + (cl-assert (or track-changes--before-no + (<= track-changes--before-beg + (track-changes--state-beg track-changes--state) + beg end + (track-changes--state-end track-changes--state) + track-changes--before-end))))) + (while track-changes--clean-trackers + (let ((tracker (pop track-changes--clean-trackers))) + (if (track-changes--tracker-immediate tracker) + (funcall (track-changes--tracker-signal tracker) tracker) + (funcall-later #'track-changes--call-signal + (current-buffer) tracker))))) + +(defun track-changes--call-signal (buf tracker) + (when (buffer-live-p buf) + (with-current-buffer buf + ;; Silence ourselves if `track-changes-fetch' was called in the mean time. + (unless (memq tracker track-changes--clean-trackers) + (funcall (track-changes--tracker-signal tracker) tracker))))) + +;;;; Extra candidates for the API. + +;; This could be a good alternative to using a temp-buffer like I used in +;; Eglot, since presumably we've just been changing this very area of the +;; buffer, so the gap should be ready nearby, +;; It may seem silly to go back to the previous state, since we could have +;; used `before-change-functions' to run FUNC right then when we were in +;; that state. The advantage is that with track-changes we get to decide +;; retroactively which state is the one for which we want to call FUNC and +;; which BEG..END to use: when that state was current we may have known +;; then that it would be "the one" but we didn't know what BEG and END +;; should be because those depend on the changes that came afterwards. +(defun track-changes--in-revert (beg end before func) + "Call FUNC with the buffer contents temporarily reverted to BEFORE. +FUNC is called with no arguments and with point right after BEFORE. +FUNC is not allowed to modify the buffer and it should refrain from using +operations that use a cache populated from the buffer's content, +such as `syntax-ppss'." + (catch 'track-changes--exit + (with-silent-modifications ;; This has to be outside `atomic-change-group'. + (atomic-change-group + (goto-char end) + (insert-before-markers before) + (delete-region beg end) + (throw 'track-changes--exit + (let ((inhibit-read-only nil) + (buffer-read-only t)) + (funcall func))))))) + +(defun track-changes--reset (id) + "Mark all past changes as handled for tracker ID. +Does not re-enable ID's signal." + (track-changes--clean-state) + (setf (track-changes--tracker-state id) track-changes--state)) + +(defun track-changes--pending-p (id) + "Return non-nil if there are pending changes for tracker ID." + (not (memq id track-changes--clean-trackers))) + +(defmacro with--track-changes (id vars &rest body) + (declare (indent 2) (debug (form sexp body))) + `(track-changes-fetch ,id (lambda ,vars ,@body))) + +(provide 'track-changes) +;;; track-changes.el end here. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 7f4284bf09d..00c09d7f06b 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -110,6 +110,7 @@ (require 'text-property-search nil t) (require 'diff-mode) (require 'diff) +(require 'track-changes) ;; These dependencies are also GNU ELPA core packages. Because of ;; bug#62576, since there is a risk that M-x package-install, despite @@ -1732,6 +1733,9 @@ eglot-utf-16-linepos "Calculate number of UTF-16 code units from position given by LBP. LBP defaults to `eglot--bol'." (/ (- (length (encode-coding-region (or lbp (eglot--bol)) + ;; FIXME: How could `point' ever be + ;; larger than `point-max' (sounds like + ;; a bug in Emacs). ;; Fix github#860 (min (point) (point-max)) 'utf-16 t)) 2) @@ -1749,6 +1753,24 @@ eglot--pos-to-lsp-position :character (progn (when pos (goto-char pos)) (funcall eglot-current-linepos-function))))) +(defun eglot--virtual-pos-to-lsp-position (pos string) + "Return the LSP position at the end of STRING if it were inserted at POS." + (eglot--widening + (goto-char pos) + (forward-line 0) + ;; LSP line is zero-origin; Emacs is one-origin. + (let ((posline (1- (line-number-at-pos nil t))) + (linebeg (buffer-substring (point) pos)) + (colfun eglot-current-linepos-function)) + ;; Use a temp buffer because: + ;; - I don't know of a fast way to count newlines in a string. + ;; - We currently don't have `eglot-current-linepos-function' for strings. + (with-temp-buffer + (insert linebeg string) + (goto-char (point-max)) + (list :line (+ posline (1- (line-number-at-pos nil t))) + :character (funcall colfun)))))) + (defvar eglot-move-to-linepos-function #'eglot-move-to-utf-16-linepos "Function to move to a position within a line reported by the LSP server. @@ -1946,6 +1968,8 @@ eglot-managed-mode-hook "A hook run by Eglot after it started/stopped managing a buffer. Use `eglot-managed-p' to determine if current buffer is managed.") +(defvar-local eglot--track-changes nil) + (define-minor-mode eglot--managed-mode "Mode for source buffers managed by some Eglot project." :init-value nil :lighter nil :keymap eglot-mode-map @@ -1959,8 +1983,9 @@ eglot--managed-mode ("utf-8" (eglot--setq-saving eglot-current-linepos-function #'eglot-utf-8-linepos) (eglot--setq-saving eglot-move-to-linepos-function #'eglot-move-to-utf-8-linepos))) - (add-hook 'after-change-functions #'eglot--after-change nil t) - (add-hook 'before-change-functions #'eglot--before-change nil t) + (unless eglot--track-changes + (setq eglot--track-changes + (track-changes-register #'eglot--track-changes-signal :disjoint t))) (add-hook 'kill-buffer-hook #'eglot--managed-mode-off nil t) ;; Prepend "didClose" to the hook after the "nonoff", so it will run first (add-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose nil t) @@ -1998,8 +2023,9 @@ eglot--managed-mode buffer (eglot--managed-buffers (eglot-current-server))))) (t - (remove-hook 'after-change-functions #'eglot--after-change t) - (remove-hook 'before-change-functions #'eglot--before-change t) + (when eglot--track-changes + (track-changes-unregister eglot--track-changes) + (setq eglot--track-changes nil)) (remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t) (remove-hook 'kill-buffer-hook #'eglot--signal-textDocument/didClose t) (remove-hook 'before-revert-hook #'eglot--signal-textDocument/didClose t) @@ -2568,54 +2594,29 @@ jsonrpc-connection-ready-p (defvar-local eglot--change-idle-timer nil "Idle timer for didChange signals.") -(defun eglot--before-change (beg end) - "Hook onto `before-change-functions' with BEG and END." - (when (listp eglot--recent-changes) - ;; Records BEG and END, crucially convert them into LSP - ;; (line/char) positions before that information is lost (because - ;; the after-change thingy doesn't know if newlines were - ;; deleted/added). Also record markers of BEG and END - ;; (github#259) - (push `(,(eglot--pos-to-lsp-position beg) - ,(eglot--pos-to-lsp-position end) - (,beg . ,(copy-marker beg nil)) - (,end . ,(copy-marker end t))) - eglot--recent-changes))) - (defvar eglot--document-changed-hook '(eglot--signal-textDocument/didChange) "Internal hook for doing things when the document changes.") -(defun eglot--after-change (beg end pre-change-length) - "Hook onto `after-change-functions'. -Records BEG, END and PRE-CHANGE-LENGTH locally." +(defun eglot--track-changes-fetch (id) + (if (eq eglot--recent-changes 'pending) (setq eglot--recent-changes nil)) + (track-changes-fetch + id (lambda (beg end before) + (if (stringp before) + (push `(,(eglot--pos-to-lsp-position beg) + ,(eglot--virtual-pos-to-lsp-position beg before) + ,(length before) + ,(buffer-substring-no-properties beg end)) + eglot--recent-changes) + (setf eglot--recent-changes :emacs-messup))))) + +(defun eglot--track-changes-signal (id &optional distance) (cl-incf eglot--versioned-identifier) - (pcase (car-safe eglot--recent-changes) - (`(,lsp-beg ,lsp-end - (,b-beg . ,b-beg-marker) - (,b-end . ,b-end-marker)) - ;; github#259 and github#367: with `capitalize-word' & friends, - ;; `before-change-functions' records the whole word's `b-beg' and - ;; `b-end'. Similarly, when `fill-paragraph' coalesces two - ;; lines, `b-beg' and `b-end' mark end of first line and end of - ;; second line, resp. In both situations, `beg' and `end' - ;; received here seemingly contradict that: they will differ by 1 - ;; and encompass the capitalized character or, in the coalescing - ;; case, the replacement of the newline with a space. We keep - ;; both markers and positions to detect and correct this. In - ;; this specific case, we ignore `beg', `len' and - ;; `pre-change-len' and send richer information about the region - ;; from the markers. I've also experimented with doing this - ;; unconditionally but it seems to break when newlines are added. - (if (and (= b-end b-end-marker) (= b-beg b-beg-marker) - (or (/= beg b-beg) (/= end b-end))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,(- b-end-marker b-beg-marker) - ,(buffer-substring-no-properties b-beg-marker - b-end-marker))) - (setcar eglot--recent-changes - `(,lsp-beg ,lsp-end ,pre-change-length - ,(buffer-substring-no-properties beg end))))) - (_ (setf eglot--recent-changes :emacs-messup))) + (cond + (distance (eglot--track-changes-fetch id)) + (eglot--recent-changes nil) + ;; Note that there are pending changes, for the benefit of those + ;; who check it as a boolean. + (t (setq eglot--recent-changes 'pending))) (when eglot--change-idle-timer (cancel-timer eglot--change-idle-timer)) (let ((buf (current-buffer))) (setq eglot--change-idle-timer @@ -2729,6 +2730,7 @@ eglot-handle-request (defun eglot--signal-textDocument/didChange () "Send textDocument/didChange to server." (when eglot--recent-changes + (eglot--track-changes-fetch eglot--track-changes) (let* ((server (eglot--current-server-or-lose)) (sync-capability (eglot-server-capable :textDocumentSync)) (sync-kind (if (numberp sync-capability) sync-capability @@ -2745,13 +2747,8 @@ eglot--signal-textDocument/didChange (buffer-substring-no-properties (point-min) (point-max))))) (cl-loop for (beg end len text) in (reverse eglot--recent-changes) - ;; github#259: `capitalize-word' and commands based - ;; on `casify_region' will cause multiple duplicate - ;; empty entries in `eglot--before-change' calls - ;; without an `eglot--after-change' reciprocal. - ;; Weed them out here. - when (numberp len) vconcat `[,(list :range `(:start ,beg :end ,end) + ;; `rangeLength' is obsolete. :rangeLength len :text text)])))) (setq eglot--recent-changes nil) (jsonrpc--call-deferred server)))) diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 66043059d14..e7ac517b72f 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -53,9 +53,10 @@ ;; - Handle `diff -b' output in context->unified. ;;; Code: +(require 'easy-mmode) +(require 'track-changes) (eval-when-compile (require 'cl-lib)) (eval-when-compile (require 'subr-x)) -(require 'easy-mmode) (autoload 'vc-find-revision "vc") (autoload 'vc-find-revision-no-save "vc") @@ -1431,56 +1432,40 @@ diff-write-contents-hooks (if (buffer-modified-p) (diff-fixup-modifs (point-min) (point-max))) nil) -;; It turns out that making changes in the buffer from within an -;; *-change-function is asking for trouble, whereas making them -;; from a post-command-hook doesn't pose much problems -(defvar diff-unhandled-changes nil) -(defun diff-after-change-function (beg end _len) - "Remember to fixup the hunk header. -See `after-change-functions' for the meaning of BEG, END and LEN." - ;; Ignoring changes when inhibit-read-only is set is strictly speaking - ;; incorrect, but it turns out that inhibit-read-only is normally not set - ;; inside editing commands, while it tends to be set when the buffer gets - ;; updated by an async process or by a conversion function, both of which - ;; would rather not be uselessly slowed down by this hook. - (when (and (not undo-in-progress) (not inhibit-read-only)) - (if diff-unhandled-changes - (setq diff-unhandled-changes - (cons (min beg (car diff-unhandled-changes)) - (max end (cdr diff-unhandled-changes)))) - (setq diff-unhandled-changes (cons beg end))))) - -(defun diff-post-command-hook () - "Fixup hunk headers if necessary." - (when (consp diff-unhandled-changes) - (ignore-errors - (save-excursion - (goto-char (car diff-unhandled-changes)) - ;; Maybe we've cut the end of the hunk before point. - (if (and (bolp) (not (bobp))) (backward-char 1)) - ;; We used to fixup modifs on all the changes, but it turns out that - ;; it's safer not to do it on big changes, e.g. when yanking a big - ;; diff, or when the user edits the header, since we might then - ;; screw up perfectly correct values. --Stef - (diff-beginning-of-hunk t) - (let* ((style (if (looking-at "\\*\\*\\*") 'context)) - (start (line-beginning-position (if (eq style 'context) 3 2))) - (mid (if (eq style 'context) - (save-excursion - (re-search-forward diff-context-mid-hunk-header-re - nil t))))) - (when (and ;; Don't try to fixup changes in the hunk header. - (>= (car diff-unhandled-changes) start) - ;; Don't try to fixup changes in the mid-hunk header either. - (or (not mid) - (< (cdr diff-unhandled-changes) (match-beginning 0)) - (> (car diff-unhandled-changes) (match-end 0))) - (save-excursion - (diff-end-of-hunk nil 'donttrustheader) - ;; Don't try to fixup changes past the end of the hunk. - (>= (point) (cdr diff-unhandled-changes)))) - (diff-fixup-modifs (point) (cdr diff-unhandled-changes))))) - (setq diff-unhandled-changes nil)))) +(defvar-local diff--track-changes nil) + +(defun diff--track-changes-signal (tracker) + (cl-assert (eq tracker diff--track-changes)) + (track-changes-fetch tracker #'diff--track-changes-function)) + +(defun diff--track-changes-function (beg end _before) + (with-demoted-errors "%S" + (save-excursion + (goto-char beg) + ;; Maybe we've cut the end of the hunk before point. + (if (and (bolp) (not (bobp))) (backward-char 1)) + ;; We used to fixup modifs on all the changes, but it turns out that + ;; it's safer not to do it on big changes, e.g. when yanking a big + ;; diff, or when the user edits the header, since we might then + ;; screw up perfectly correct values. --Stef + (diff-beginning-of-hunk t) + (let* ((style (if (looking-at "\\*\\*\\*") 'context)) + (start (line-beginning-position (if (eq style 'context) 3 2))) + (mid (if (eq style 'context) + (save-excursion + (re-search-forward diff-context-mid-hunk-header-re + nil t))))) + (when (and ;; Don't try to fixup changes in the hunk header. + (>= beg start) + ;; Don't try to fixup changes in the mid-hunk header either. + (or (not mid) + (< end (match-beginning 0)) + (> beg (match-end 0))) + (save-excursion + (diff-end-of-hunk nil 'donttrustheader) + ;; Don't try to fixup changes past the end of the hunk. + (>= (point) end))) + (diff-fixup-modifs (point) end)))))) (defun diff-next-error (arg reset) ;; Select a window that displays the current buffer so that point @@ -1560,9 +1545,8 @@ diff-mode ;; setup change hooks (if (not diff-update-on-the-fly) (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) - (make-local-variable 'diff-unhandled-changes) - (add-hook 'after-change-functions #'diff-after-change-function nil t) - (add-hook 'post-command-hook #'diff-post-command-hook nil t)) + (setq diff--track-changes + (track-changes-register #'diff--track-changes-signal :nobefore t))) ;; add-log support (setq-local add-log-current-defun-function #'diff-current-defun) @@ -1581,12 +1565,15 @@ diff-minor-mode \\{diff-minor-mode-map}" :group 'diff-mode :lighter " Diff" ;; FIXME: setup font-lock - ;; setup change hooks - (if (not diff-update-on-the-fly) - (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) - (make-local-variable 'diff-unhandled-changes) - (add-hook 'after-change-functions #'diff-after-change-function nil t) - (add-hook 'post-command-hook #'diff-post-command-hook nil t))) + (when diff--track-changes (track-changes-unregister diff--track-changes)) + (remove-hook 'write-contents-functions #'diff-write-contents-hooks t) + (when diff-minor-mode + (if (not diff-update-on-the-fly) + (add-hook 'write-contents-functions #'diff-write-contents-hooks nil t) + (unless diff--track-changes + (setq diff--track-changes + (track-changes-register #'diff--track-changes-signal + :nobefore t)))))) ;;; Handy hook functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test/lisp/emacs-lisp/track-changes-tests.el b/test/lisp/emacs-lisp/track-changes-tests.el new file mode 100644 index 00000000000..cdccbe80299 --- /dev/null +++ b/test/lisp/emacs-lisp/track-changes-tests.el @@ -0,0 +1,149 @@ +;;; track-changes-tests.el --- tests for emacs-lisp/track-changes.el -*- lexical-binding:t -*- + +;; Copyright (C) 2024 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'track-changes) +(require 'cl-lib) +(require 'ert) + +(defun track-changes-tests--random-word () + (let ((chars ())) + (dotimes (_ (1+ (random 12))) + (push (+ ?A (random (1+ (- ?z ?A)))) chars)) + (apply #'string chars))) + +(defvar track-changes-tests--random-verbose nil) + +(defun track-changes-tests--message (&rest args) + (when track-changes-tests--random-verbose (apply #'message args))) + +(ert-deftest track-changes-tests--random () + ;; Keep 2 buffers in sync with a third one as we make random + ;; changes to that 3rd one. + ;; We have 3 trackers: a "normal" one which we sync + ;; at random intervals, one which syncs via the "disjoint" signal, + ;; plus a third one which verifies that "nobefore" gets + ;; information consistent with the "normal" tracker. + (with-temp-buffer + (dotimes (_ 100) + (insert (track-changes-tests--random-word) "\n")) + (let* ((buf1 (generate-new-buffer " *tc1*")) + (buf2 (generate-new-buffer " *tc2*")) + (char-counts (make-vector 2 0)) + (sync-counts (make-vector 2 0)) + (print-escape-newlines t) + (file (make-temp-file "tc")) + (id1 (track-changes-register #'ignore)) + (id3 (track-changes-register #'ignore :nobefore t)) + (sync + (lambda (id buf n) + (track-changes-tests--message "!! SYNC %d !!" n) + (track-changes-fetch + id (lambda (beg end before) + (when (eq n 1) + (track-changes-fetch + id3 (lambda (beg3 end3 before3) + (should (eq beg3 beg)) + (should (eq end3 end)) + (should (eq before3 + (if (symbolp before) + before (length before))))))) + (cl-incf (aref sync-counts (1- n))) + (cl-incf (aref char-counts (1- n)) (- end beg)) + (let ((after (buffer-substring beg end))) + (track-changes-tests--message + "Sync:\n %S\n=> %S\nat %d .. %d" + before after beg end) + (with-current-buffer buf + (if (eq before 'error) + (erase-buffer) + (should (equal before + (buffer-substring + beg (+ beg (length before))))) + (delete-region beg (+ beg (length before)))) + (goto-char beg) + (insert after))) + (should (equal (buffer-string) + (with-current-buffer buf + (buffer-string)))))))) + (id2 (track-changes-register + (lambda (id2 &optional distance) + (when distance + (track-changes-tests--message "Disjoint distance: %d" + distance) + (funcall sync id2 buf2 2))) + :disjoint t))) + (write-region (point-min) (point-max) file) + (insert-into-buffer buf1) + (insert-into-buffer buf2) + (should (equal (buffer-hash) (buffer-hash buf1))) + (should (equal (buffer-hash) (buffer-hash buf2))) + (dotimes (_ 1000) + (pcase (random 15) + (0 + (track-changes-tests--message "Manual sync1") + (funcall sync id1 buf1 1)) + (1 + (track-changes-tests--message "Manual sync2") + (funcall sync id2 buf2 2)) + ((pred (< _ 5)) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 100))) (point-max)))) + (track-changes-tests--message "Fill %d .. %d" beg end) + (fill-region-as-paragraph beg end))) + ((pred (< _ 8)) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 12))) (point-max)))) + (track-changes-tests--message "Delete %S at %d .. %d" + (buffer-substring beg end) beg end) + (delete-region beg end))) + ((and 8 (guard (= (random 50) 0))) + (track-changes-tests--message "Silent insertion") + (let ((inhibit-modification-hooks t)) + (insert "a"))) + ((and 8 (guard (= (random 10) 0))) + (track-changes-tests--message "Revert") + (insert-file-contents file nil nil nil 'replace)) + ((and 8 (guard (= (random 3) 0))) + (let* ((beg (+ (point-min) (random (1+ (buffer-size))))) + (end (min (+ beg (1+ (random 12))) (point-max))) + (after (eq (random 2) 0))) + (track-changes-tests--message "Bogus %S %d .. %d" + (if after 'after 'before) beg end) + (if after + (run-hook-with-args 'after-change-functions + beg end (- end beg)) + (run-hook-with-args 'before-change-functions beg end)))) + (_ + (goto-char (+ (point-min) (random (1+ (buffer-size))))) + (let ((word (track-changes-tests--random-word))) + (track-changes-tests--message "insert %S at %d" word (point)) + (insert word "\n"))))) + (message "SCOREs: default: %d/%d=%d disjoint: %d/%d=%d" + (aref char-counts 0) (aref sync-counts 0) + (/ (aref char-counts 0) (aref sync-counts 0)) + (aref char-counts 1) (aref sync-counts 1) + (/ (aref char-counts 1) (aref sync-counts 1)))))) + + + +;;; track-changes-tests.el ends here -- 2.43.0