;;; 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 the following operations:
;;
;;     (track-changes-register SIGNAL)
;;     (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 ()
;;                    (track-changes-fetch
;;                     my-foo--change-tracker
;;                     (lambda (beg end before)
;;                       ..DO THE THING..))))))))

;;; Code:

;; FIXME: Try and do some sanity-checks (e.g. looking at `buffer-size'),
;; to detect if/when we somehow missed some changes.
;; FIXME: The API doesn't offer an easy way to signal a "full resync"
;; kind of change, as might be needed if we lost changes.

(require 'cl-lib)

(cl-defstruct (track-changes--tracker
               (:noinline t)
               (:constructor nil)
               (:constructor track-changes--tracker ( signal state)))
  ( signal nil :read-only t)
  state)

(cl-defstruct (track-changes--state
               (:noinline t)
               (:constructor nil)
               (:constructor track-changes--state ()))
  (beg (point-max))
  (end (point-min))
  (bbeg (point-max))                    ;BEG of the BEFORE string,
  (bend (point-min))                    ;END of the BEFORE string.
  (before nil)
  (next nil))

(defvar-local track-changes--trackers ())
(defvar-local track-changes--clean-trackers ())

(defvar-local track-changes--state nil)

(defun track-changes-register ( signal)
  "Register a new tracker and return a new tracker ID.
SIGNAL is a function that will be called with no argument when
the current buffer is modified, so that we can react to the change.
Once called, SIGNAL is not called again until `track-changes-fetch'
is called with the corresponding tracker ID."
  ;; FIXME: Add an optional arg to choose between `funcall' and `funcall-later'?
  (track-changes--clean-state)
  (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)))
    (push tracker track-changes--trackers)
    (push tracker track-changes--clean-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))
  (when (null track-changes--trackers)
    (setq track-changes--state nil)
    (remove-hook 'before-change-functions #'track-changes--before t)
    (remove-hook 'after-change-functions  #'track-changes--after  t)))


(defun track-changes--clean-p ()
  (null (track-changes--state-before track-changes--state)))

(defun track-changes--clean-state ()
  (cond
   ((null track-changes--state)
    ;; No state has been created yet.  Do it now.
    (setq track-changes--state (track-changes--state)))
   ((track-changes--clean-p) nil)
   (t
    ;; FIXME: We may be in-between a before-c-f and an after-c-f, so we
    ;; should save some of the current buffer in case an after-c-f comes
    ;; before a before-c-f.
    (let ((new (track-changes--state)))
      (setf (track-changes--state-next track-changes--state) new)
      (setq track-changes--state new)))))

(defun track-changes--before (beg end)
  (cl-assert track-changes--state)
  (cl-assert (<= beg end))
  (if (track-changes--clean-p)
      (progn
        (setf (track-changes--state-before track-changes--state)
              (buffer-substring-no-properties beg end))
        (setf (track-changes--state-bbeg track-changes--state) beg)
        (setf (track-changes--state-bend track-changes--state) end))
    (cl-assert
     (save-restriction
       (widen)
       (<= (point-min)
           (track-changes--state-bbeg track-changes--state)
           (track-changes--state-bend track-changes--state)
           (point-max))))
    (when (< beg (track-changes--state-bbeg track-changes--state))
      (let* ((old-bbeg (track-changes--state-bbeg track-changes--state))
             ;; 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--state-before
                                             track-changes--state))))
                            beg)))
        (setf (track-changes--state-bbeg track-changes--state) beg)
        (cl-callf (lambda (old new) (concat new old))
            (track-changes--state-before track-changes--state)
          (buffer-substring-no-properties new-bbeg old-bbeg))))

    (when (< (track-changes--state-bend track-changes--state) end)
      (let* ((old-bend (track-changes--state-bend track-changes--state))
             ;; 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--state-before
                                             track-changes--state))))
                            end)))
        (setf (track-changes--state-bend track-changes--state) end)
        (cl-callf concat (track-changes--state-before track-changes--state)
          (buffer-substring-no-properties old-bend new-bend))))))

(defun track-changes--after (beg end len)
  (cl-assert track-changes--state)
  (cl-assert (track-changes--state-before track-changes--state))
  (let ((offset (- (- end beg) len)))
    (cl-incf (track-changes--state-bend track-changes--state) offset)
    (cl-assert
     (save-restriction
       (widen)
       (<= (point-min)
           (track-changes--state-bbeg track-changes--state)
           beg end
           (track-changes--state-bend track-changes--state)
           (point-max))))
    ;; 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 (<= (track-changes--state-bbeg track-changes--state)
                 (track-changes--state-beg track-changes--state)
                 beg end
                 (track-changes--state-end track-changes--state)
                 (track-changes--state-bend track-changes--state)))
  (while track-changes--clean-trackers
    (let ((tracker (pop track-changes--clean-trackers)))
      ;; FIXME: Use `funcall'?
      (funcall-later (track-changes--tracker-signal tracker) ()))))

(defun track-changes-fetch (id func)
  "Fetch the pending changes.
ID is the tracker ID returned by a previous `track-changes-register'.
FUNC is a function.  It is called with 3 arguments (BEGIN END BEFORE)
where BEGIN..END delimit the region that was changed since the last
time `track-changes-fetch' was called and BEFORE is a string containing
the previous content of that region.

If no changes occurred since the last time, FUNC is not called and
we return nil, otherwise we return the value returned by FUNC,
and re-enable the TRACKER corresponding to ID."
  (let ((beg nil)
        (end nil)
        (before nil)
        (states ()))
    ;; 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))))
    (when (null (track-changes--state-before (car states)))
      (cl-assert (eq (car states) track-changes--state))
      (setq states (cdr states)))
    (if (null states)
        (progn
          (cl-assert (memq id track-changes--clean-trackers))
          nil)
      (dolist (state states)
        (let ((prevbbeg (track-changes--state-bbeg state))
              (prevbend (track-changes--state-bend state))
              (prevbefore (track-changes--state-before state)))
          (if (not before)
              (progn
                ;; This is the most recent change.  Just initialize the vars.
                (setq beg (track-changes--state-beg state))
                (setq end (track-changes--state-end state))
                (setq before prevbefore)
                (unless (and (= beg prevbbeg) (= end prevbend))
                  (setq before
                        (substring before
                                   (- beg (track-changes--state-bbeg state))
                                   (- (length before)
                                      (- (track-changes--state-bend state)
                                         end))))))
            ;; FIXME: When merging "states", we disregard the `beg/end'
            ;; in favor of `bbeg/bend' which also works but is conservative.
            (let ((endb (+ beg (length before))))
              (when (< prevbbeg beg)
                (setq before (concat (buffer-substring-no-properties
                                      prevbbeg beg)
                                     before))
                (setq beg prevbbeg)
                (cl-assert (= endb (+ beg (length before)))))
              (when (< endb prevbend)
                (let ((new-end (+ end (- prevbend endb))))
                  (setq before (concat before
                                       (buffer-substring-no-properties
                                        end new-end)))
                  (setq end new-end)
                  (cl-assert (= prevbend (+ beg (length before))))
                  (setq endb (+ beg (length before)))))
              (cl-assert (<= beg prevbbeg prevbend endb))
              ;; The `prevbefore' is covered by the new one.
              (setq before
                    (concat (substring before 0 (- prevbbeg beg))
                            prevbefore
                            (substring before (- (length before)
                                                 (- endb prevbend)))))))))
      (cl-assert (<= (point-min) beg end (point-max)))
      ;; Clean the state of the tracker before calling `func', in case
      ;; `func' performs buffer modifications.
      (track-changes--clean-state)
      ;; 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 before)
        ;; Re-enable the tracker's signal only after running `func', so
        ;; as to avoid recursive invocations.
        (cl-pushnew id track-changes--clean-trackers)))))

(defmacro with-track-changes (id vars &rest body)
  (declare (indent 2) (debug (form sexp body)))
  `(track-changes-fetch ,id (lambda ,vars ,@body)))
                        

(provide 'track-changes)
;;; track-changes.el end here.