[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/track-changes 820011a2542: lisp/emacs-lisp/track-changes.el: New
|
From: |
Stefan Monnier |
|
Subject: |
scratch/track-changes 820011a2542: lisp/emacs-lisp/track-changes.el: New file |
|
Date: |
Tue, 9 Apr 2024 22:29:07 -0400 (EDT) |
branch: scratch/track-changes
commit 820011a254231d6255b0d7fe07ff4ab1314c3b6e
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>
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.
* doc/lispref/text.texi (Tracking changes): New subsection.
* 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` when available.
(eglot--track-changes-signal): New function, partly extracted from
`eglot--after-change`.
(eglot--after-change): Use it.
(eglot--track-changes-fetch): New function.
(eglot--signal-textDocument/didChange): Use it.
* 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`.
---
doc/lispref/text.texi | 148 +++++++
etc/NEWS | 18 +
lisp/emacs-lisp/track-changes.el | 619 ++++++++++++++++++++++++++++
lisp/progmodes/eglot.el | 64 ++-
lisp/vc/diff-mode.el | 85 ++--
test/lisp/emacs-lisp/track-changes-tests.el | 156 +++++++
6 files changed, 1037 insertions(+), 53 deletions(-)
diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 18f0ee88fe5..8774801f41f 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -6375,3 +6375,151 @@ hooks during a series of changes (typically for
performance reasons),
use @code{combine-change-calls} or @code{combine-after-change-calls}
instead.
@end defvar
+
+@node Tracking changes
+@subsection Tracking changes
+@cindex track-changes
+@cindex change tracker
+
+Using @code{before-change-functions} and @code{after-change-functions}
+can be difficult in practice because of a number of pitfalls, such as
+the fact that the two calls are not always properly paired, or some
+calls may be missing, either because some Emacs primitives failed to
+properly pair them or because of incorrect use of
+@code{inhibit-modification-hooks}. Furthermore,
+many restrictions apply to those hook functions, such as the fact that
+they basically should never modify the current buffer, nor use an
+operation that may block, and they proceed quickly because
+some commands may call these hooks a large number of times.
+
+The Track-Changes library fundamentally provides an alternative API,
+built on top of those hooks. Compared to @code{after-change-functions},
+the first important difference is that, instead of providing the bounds
+of the change and the previous length, it provides the bounds of the
+change and the actual previous content of that region. The need to
+extract information from the original contents of the buffer is one of
+the main reasons why some packages need to use both
+@code{before-change-functions} and @code{after-change-functions} and
+then try to match them up.
+
+The second difference is that it decouples the notification of a change
+from the act of processing it, and it automatically combines into
+a single change operation all the changes that occur between the first
+change and the actual processing. This makes it natural and easy to
+process the changes at a larger granularity, such as once per command,
+and eliminates most of the restrictions that apply to the usual change
+hook functions, making it possible to use blocking operations or to
+modify the buffer.
+
+To start tracking changes, you have to call
+@code{track-changes-register}, passing it a @var{signal} function as
+argument. This returns a tracker @var{id} which is used to identify
+your change tracker to the other functions of the library.
+When the buffer is modified, the library calls the @var{signal}
+function to inform you of that change and immediately starts
+accumulating subsequent changes into a single combined change.
+The @var{signal} function serves only to warn that a modification
+occurred but does not receive a description of the change. Also the
+library will not call it again until after you retrieved the change.
+
+To retrieve changes, you need to call @code{track-changes-fetch}, which
+provides you with the bounds of the changes accumulated since the
+last call, as well as the previous content of that region. It also
+``re-arms'' the @var{signal} function so that the library will call it
+again after the next buffer modification.
+
+@defun track-changes-register signal &key nobefore disjoint immediate
+This function creates a new @dfn{change tracker}. Change trackers are kept
+abstract, so we refer to them as mere identities, and the function thus
+returns the tracker's @var{id}.
+
+@var{signal} is a function that the library will call to notify of
+a change. It will sometimes call it with a single argument and
+sometimes with two. Upon the first change to the buffer since this
+tracker last called @code{track-changes-fetch}, the library calls this
+@var{signal} function with a single argument holding the @var{id} of
+the tracker.
+
+By default, the call to the @var{signal} function does not happen
+immediately, but is instead postponed with a 0 seconds timer
+(@pxref{Timers}). This is usually desired to make sure the @var{signal}
+function is not called too frequently and runs in a permissive context,
+freeing the client from performance concerns or worries about which
+operations might be problematic. If a client wants to have more
+control, they can provide a non-@code{nil} value as the @var{immediate}
+argument in which case the library calls the @var{signal} function
+directly from @code{after-change-functions}. Beware that it means that
+the @var{signal} function has to be careful not to modify the buffer or
+use operations that may block.
+
+If you're not interested in the actual previous content of the buffer,
+but are using this library only for its ability to combine many small
+changes into a larger one and to delay the processing to a more
+convenient time, you can specify a non-@code{nil} value for the
+@var{nobefore} argument. In that case, @code{track-change-fetch}
+provides you only with the length of the previous content, just like
+@code{after-change-functions}. It also allows the library to save
+some work.
+
+While you may like to accumulate many small changes into larger ones,
+you may not want to do that if the changes are too far apart. If you
+specify a non-@code{nil} value for the @var{disjoint} argument, the library
+will let you know when a change is about to occur ``far'' from the
+currently pending ones by calling the @var{signal} function right away,
+passing it two arguments this time: the @var{id} of the tracker, and the
+number of characters that separates the upcoming change from the
+already pending changes. This in itself does not prevent combining this
+new change with the previous ones, so if you think the upcoming change
+is indeed too far, you need to call @code{track-change-fetch}
+right away.
+Beware that when the @var{signal} function is called because of
+a disjoint change, this happens directly from
+@code{before-change-functions}, so the usual restrictions apply about
+modifying the buffer or using operations that may block.
+@end defun
+
+@defun track-changes-fetch id func
+This is the function that lets you find out what has changed in the
+buffer. By providing the tracker @var{id} you let the library figure
+out which changes have already been seen by your tracker. Instead of
+returning a description of the changes, @code{track-changes-fetch} calls
+the @var{func} function with that description in the form of
+3 arguments: @var{beg}, @var{end}, and @var{before}, where
+@code{@var{beg}..@var{end}} delimit the region that was modified and
+@var{before} describes the previous content of that region.
+Usually @var{before} is a string containing the previous text of the
+modified region, but if you specified a non-@code{nil} @var{nobefore} argument
+to @code{track-changes-register}, then it is replaced by the number of
+characters of that previous text.
+
+In case no changes occurred since the last call,
+@code{track-changes-fetch} simply does not call @var{func} and returns
+@code{nil}. If changes did occur, it calls @var{func} and returns the value
+returned by @var{func}. But note that @var{func} is called just once
+regardless of how many changes occurred: those are summarized into
+a single @var{beg}/@var{end}/@var{before} triplet.
+
+In some cases, the library is not properly notified of all changes,
+for example because of a bug in the low-level C code or because of an
+improper use of @code{inhibit-modification-hooks}. When it detects such
+a problem, @var{func} receives a @code{@var{beg}..@var{end}} region
+which covers the whole buffer and the @var{before} argument is the
+symbol @code{error} to indicate that the library was unable to determine
+what was changed.
+
+Once @var{func} finishes, @code{track-changes-fetch} re-enables the
+@var{signal} function so that it will be called the next time a change
+occurs. This is the reason why it calls @var{func} instead of returning
+a description: it lets you process the change without worrying about the
+risk that the @var{signal} function gets triggered in the middle of it,
+because the @var{signal} is re-enabled only after @var{func} finishes.
+@end defun
+
+@defun track-changes-unregister id
+This function tells the library that the tracker @var{id} does not need
+to know about buffer changes any more. Most clients will never want to
+stop tracking changes, but for clients such as minor modes, it is
+important to call this function when the minor mode is disabled,
+otherwise the tracker will keep accumulating changes and consume more
+and more resources.
+@end defun
diff --git a/etc/NEWS b/etc/NEWS
index a2a3fe494cb..2cf6477ba99 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -15,6 +15,12 @@ in older Emacs versions.
You can narrow news to a specific version by calling 'view-emacs-news'
with a prefix argument or by typing 'C-u C-h C-n'.
+Temporary note:
++++ indicates that all relevant manuals in doc/ have been updated.
+--- means no change in the manuals is needed.
+When you add a new item, use the appropriate mark if you are sure it
+applies, and please also update docstrings as needed.
+
* Installation Changes in Emacs 30.1
@@ -1586,6 +1592,18 @@ options of GNU 'ls'.
* New Modes and Packages in Emacs 30.1
++++
+** New package Track-Changes.
+This library is a layer of abstraction above 'before-change-functions'
+and 'after-change-functions' which provides a superset of
+the functionality of 'after-change-functions':
+- It provides the actual previous text rather than only its length.
+- It takes care of accumulating and bundling changes until a time when
+ its client finds it convenient to react to them.
+- It detects most cases where some changes were not properly
+ reported (calls to 'before/after-change-functions' that are
+ incorrectly paired, missing, etc...) and reports them adequately.
+
** New major modes based on the tree-sitter library
+++
diff --git a/lisp/emacs-lisp/track-changes.el b/lisp/emacs-lisp/track-changes.el
new file mode 100644
index 00000000000..3479fecef25
--- /dev/null
+++ b/lisp/emacs-lisp/track-changes.el
@@ -0,0 +1,619 @@
+;;; track-changes.el --- API to react to buffer modifications -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2024 Free Software Foundation, Inc.
+
+;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+
+;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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:
+
+;; Random ideas:
+;; - We could let trackers specify a function to record auxiliary info
+;; about a state. This would be called from the first before-c-f
+;; and then provided to FUNC. TeXpresso could use it to avoid needing
+;; the BEFORE string: it could record the total number of bytes
+;; in the "before" state so that from `track-changes-fetch' it could
+;; compute the number of bytes that used to be in BEG/END.
+
+(require 'cl-lib)
+
+;;;; 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.
+A buffer state is described by a BEG/END/BEFORE triplet which say how to
+recover that state from the next state. I.e. if the buffer's contents
+reflects the next state, you can recover the previous state by replacing
+the BEG..END region with the BEFORE string.
+
+NEXT is the next state object (i.e. a more recent state).
+If NEXT is nil it means it's the 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 created."
+ (beg (point-max))
+ (end (point-min))
+ (before nil)
+ (next nil))
+
+(defvar-local track-changes--trackers ()
+ "List of trackers currently registered in the 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 0
+ "Beginning position of the remembered \"before string\".")
+(defvar-local track-changes--before-end 0
+ "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
+ "Status of `track-changes--before-*' vars.
+More specifically it indicates which \"before\" they hold.
+- nil: The vars hold the \"before\" info of the current state.
+- `unset': The vars hold the \"before\" info of some older state.
+ This is what it is set to right after creating a fresh new state.
+- `set': Like nil but the state is still clean because the buffer has not
+ been modified yet. 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 whose change-tracking function is SIGNAL.
+Return the ID of the new tracker.
+
+SIGNAL is a function that will be called with one argument (the tracker ID)
+after the current buffer is modified, so that it 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).
+
+If optional argument DISJOINT is non-nil, SIGNAL is called every time just
+before combining 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.
+
+By default SIGNAL is called after a change via a 0 seconds timer.
+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 probably not always call
+`track-changes-fetch', since that would defeat the purpose of this library."
+ (when (and nobefore disjoint)
+ ;; FIXME: Without `before-change-functions', we can discover
+ ;; a disjoint change only after the fact, which is not good enough.
+ ;; But we could use a 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 for tracker ID pass them to FUNC.
+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 track-changes detected that some changes were missed, 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, it doesn't call FUNC and
+returns nil, otherwise it returns 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 (not (memq id track-changes--clean-trackers)))
+ (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
+ ;; If the state is already clean, there's nothing to do.
+ 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
+ "Number of chars 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)
+ (run-with-timer 0 nil #'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.
+
+;; The functions below came up during the design of this library, but
+;; I'm not sure if they're worth the trouble or not, so for now I keep
+;; them here (with a "--" in the name) for documentation. --Stef
+
+;; This could be a good alternative to using a temp-buffer like in
+;; `eglot--virtual-pos-to-lsp-position': since presumably we've just
+;; been changing this very area of the buffer, the gap should be
+;; ready nearby, so the operation should be fairly cheap, while
+;; giving you the comfort of having access to the *full* buffer text.
+;;
+;; 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)))))))
+
+;; This one might be useful for example if a client makes changes to
+;; the buffer and doesn't want to see its own changes.
+(defun track-changes--reset (id)
+ "Mark all past changes as handled for tracker ID.
+Re-arms ID's signal."
+ (track-changes--clean-state)
+ (setf (track-changes--tracker-state id) track-changes--state)
+ (cl-pushnew id track-changes--clean-trackers)
+ (cl-assert (not (track-changes--pending-p id))))
+
+(defun track-changes--pending-p (id)
+ "Return non-nil if there are pending changes for tracker ID."
+ (or (not track-changes--before-clean)
+ (track-changes--state-next id)))
+
+(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..478e7687bb3 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 nil t)
;; 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 @@ return value is fed through the corresponding inverse
function
"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 @@ LBP defaults to `eglot--bol'."
: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 @@ For example, to keep your Company customization, add the
symbol
"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,13 @@ Use `eglot-managed-p' to determine if current buffer is
managed.")
("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)
+ (if (fboundp 'track-changes-register)
+ (unless eglot--track-changes
+ (setq eglot--track-changes
+ (track-changes-register
+ #'eglot--track-changes-signal :disjoint t)))
+ (add-hook 'after-change-functions #'eglot--after-change nil t)
+ (add-hook 'before-change-functions #'eglot--before-change nil 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,6 +2027,9 @@ Use `eglot-managed-p' to determine if current buffer is
managed.")
buffer
(eglot--managed-buffers (eglot-current-server)))))
(t
+ (when eglot--track-changes
+ (track-changes-unregister eglot--track-changes)
+ (setq eglot--track-changes nil))
(remove-hook 'after-change-functions #'eglot--after-change t)
(remove-hook 'before-change-functions #'eglot--before-change t)
(remove-hook 'kill-buffer-hook #'eglot--managed-mode-off t)
@@ -2588,7 +2620,6 @@ buffer."
(defun eglot--after-change (beg end pre-change-length)
"Hook onto `after-change-functions'.
Records BEG, END and PRE-CHANGE-LENGTH locally."
- (cl-incf eglot--versioned-identifier)
(pcase (car-safe eglot--recent-changes)
(`(,lsp-beg ,lsp-end
(,b-beg . ,b-beg-marker)
@@ -2616,6 +2647,29 @@ Records BEG, END and PRE-CHANGE-LENGTH locally."
`(,lsp-beg ,lsp-end ,pre-change-length
,(buffer-substring-no-properties beg end)))))
(_ (setf eglot--recent-changes :emacs-messup)))
+ (eglot--track-changes-signal nil))
+
+(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)
+ (cond
+ ((eq eglot--recent-changes :emacs-messup) nil)
+ ((eq before 'error) (setf eglot--recent-changes :emacs-messup))
+ (t (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))))))
+
+(defun eglot--track-changes-signal (id &optional distance)
+ (cl-incf eglot--versioned-identifier)
+ (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 +2783,8 @@ When called interactively, use the currently active
server"
(defun eglot--signal-textDocument/didChange ()
"Send textDocument/didChange to server."
(when eglot--recent-changes
+ (when eglot--track-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
@@ -2750,7 +2806,7 @@ When called interactively, use the currently active
server"
;; empty entries in `eglot--before-change' calls
;; without an `eglot--after-change' reciprocal.
;; Weed them out here.
- when (numberp len)
+ when (numberp len) ;FIXME: Not needed with `track-changes'.
vconcat `[,(list :range `(:start ,beg :end ,end)
:rangeLength len :text text)]))))
(setq eglot--recent-changes nil)
diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el
index 66043059d14..0a618dc8f39 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,38 +1432,23 @@ else cover the whole buffer."
(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)
+(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
+ (when (ignore-errors (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)
@@ -1470,17 +1456,16 @@ See `after-change-functions' for the meaning of BEG,
END and LEN."
(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)
+ (>= beg 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)))
+ (< end (match-beginning 0))
+ (> beg (match-end 0)))
(save-excursion
- (diff-end-of-hunk nil 'donttrustheader)
+ (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))))
+ (>= (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 @@ a diff with \\[diff-reverse-direction].
;; 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 @@ a diff with \\[diff-reverse-direction].
\\{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..ed35477cafd
--- /dev/null
+++ b/test/lisp/emacs-lisp/track-changes-tests.el
@@ -0,0 +1,156 @@
+;;; 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 <https://www.gnu.org/licenses/>.
+
+;;; 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)))
+
+(defvar track-changes-tests--random-seed
+ (let ((seed (number-to-string (random (expt 2 24)))))
+ (message "Random seed = %S" seed)
+ seed))
+
+(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
+ (random track-changes-tests--random-seed)
+ (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)))
+ (message "seeding with: %S" track-changes-tests--random-seed)
+ (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