mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2025-01-08 15:35:02 +00:00
Code Issues Releases Activity

lisp/emacs-lisp/track-changes.el: New file (bug#70077)

Browse Source 
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`.
This commit is contained in:
Stefan Monnier 2024-04-05 17:37:32 -04:00
parent dd6b9c9426
commit d7a83e23d4
6 changed files with 1045 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
doc/lispref/text.texi
View File

@ -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

18
etc/NEWS
View File

@ -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
+++

624
lisp/emacs-lisp/track-changes.el Normal file
View File

@ -0,0 +1,624 @@
;;; 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.
;; - We could also let them provide another function to run in
;; before-c-f to signal errors if the change is not acceptable,
;; but contrary to before-c-f it would be called only when we
;; move t-c--before-beg/end so it scales better when there are
;; many small changes.
(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 is a cheaper version of (track-changes-fetch id #'ignore),
;; e.g. for clients that don't want to see their 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.

64
lisp/progmodes/eglot.el
View File

@ -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)

87
lisp/vc/diff-mode.el
View File

@ -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)))))
(defvar-local diff--track-changes nil)
(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)
(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,20 @@ 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)
;; Ignore the changes we just made ourselves.
;; This is not indispensable since the above `when' skips
;; changes like the ones we make anyway, but it's good practice.
(track-changes-fetch diff--track-changes #'ignore)))))))
(defun diff-next-error (arg reset)
;; Select a window that displays the current buffer so that point
@ -1560,9 +1549,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 +1569,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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

156
test/lisp/emacs-lisp/track-changes-tests.el Normal file
View File

@ -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