Publish client-owned side state after retained surfaces and roll it back in reverse order on any transaction failure.\n\nVerified: 715 ERT tests, 92 doctests, WERROR compile-all, checkdoc, git diff --check.
1247 lines
54 KiB
EmacsLisp
1247 lines
54 KiB
EmacsLisp
;;; tp-reactive.el --- Exact signals and binding scheduler -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024-2026 Geekinney
|
|
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
|
|
;; This program 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.
|
|
|
|
;;; Commentary:
|
|
|
|
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
|
|
;; scheduler, scoped variable adapters, and rollback state. The lower legacy
|
|
;; section remains temporarily available to the 0.3 layer/render facade during
|
|
;; the staged cutover; new graph execution never calls its scan renderer.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'tp-core)
|
|
|
|
(define-error 'tp-reactive-error "TP reactive runtime error")
|
|
(define-error 'tp-invalid-signal-scope "Invalid TP signal scope"
|
|
'tp-reactive-error)
|
|
(define-error 'tp-disposed-signal "TP signal is disposed" 'tp-reactive-error)
|
|
(define-error 'tp-disposed-binding "TP binding is disposed" 'tp-reactive-error)
|
|
(define-error 'tp-binding-cycle "TP binding dependency cycle"
|
|
'tp-reactive-error)
|
|
|
|
(cl-defstruct (tp-signal (:constructor tp--make-signal))
|
|
"Reactive source with a committed value and exact subscribers."
|
|
id committed-value equality subscribers scope adapter-key disposed revision)
|
|
|
|
(cl-defstruct (tp-binding (:constructor tp--make-binding))
|
|
"Memoized computation installed on one owner and namespaced key."
|
|
id owner key compute equality last-value initialized-p dependencies
|
|
subscribers dirty state revision lifecycle disposed)
|
|
|
|
(cl-defstruct (tp--binding-snapshot
|
|
(:constructor tp--make-binding-snapshot))
|
|
compute equality last-value initialized-p dependencies dirty state
|
|
revision lifecycle disposed)
|
|
|
|
(cl-defstruct (tp--transaction-participant
|
|
(:constructor tp--make-transaction-participant))
|
|
"One rollback-capable side-state participant in a TP transaction."
|
|
key publish rollback)
|
|
|
|
(defconst tp--reactive-absent (make-symbol "tp-reactive-absent"))
|
|
|
|
(defvar tp--signal-id-counter 0)
|
|
(defvar tp--binding-id-counter 0)
|
|
(defvar tp--signals nil)
|
|
(defvar tp--bindings nil)
|
|
(defvar tp--owner-bindings (make-hash-table :test #'eq))
|
|
(defvar tp--variable-signals (make-hash-table :test #'equal))
|
|
(defvar tp--variable-signal-watched nil)
|
|
|
|
(defvar-local tp--buffer-signals nil)
|
|
|
|
(defvar tp--reactive-counters
|
|
(list :invalidated 0 :recomputed 0 :skipped 0
|
|
:subscription-added 0 :subscription-removed 0))
|
|
|
|
(defvar tp--transaction-active nil)
|
|
(defvar tp--transaction-signal-values nil)
|
|
(defvar tp--transaction-signals nil)
|
|
(defvar tp--transaction-dirty-set nil)
|
|
(defvar tp--transaction-dirty-queue nil)
|
|
(defvar tp--transaction-binding-snapshots nil)
|
|
(defvar tp--transaction-created-bindings nil)
|
|
(defvar tp--transaction-recompute-counts nil)
|
|
(defvar tp--transaction-extensions nil)
|
|
(defvar tp--transaction-counter-start nil)
|
|
(defvar tp--transaction-after-commit-callbacks nil)
|
|
(defvar tp--transaction-participants nil)
|
|
(defvar tp--transaction-participant-keys nil)
|
|
(defvar tp--transaction-published-participants nil)
|
|
(defvar tp--current-binding nil)
|
|
(defvar tp--binding-compute-stack nil)
|
|
(defvar tp--collected-dependency-set nil)
|
|
(defvar tp--collected-dependencies nil)
|
|
(defvar tp--binding-touch-function nil)
|
|
(defvar tp--binding-changed-functions nil)
|
|
(defvar tp--transaction-publish-functions nil)
|
|
(defvar tp--transaction-rollback-functions nil)
|
|
(defvar tp--transaction-rollback-final-functions nil)
|
|
(defvar tp--transaction-committed-functions nil)
|
|
|
|
(defun tp--counter-increment (key)
|
|
"Increment reactive counter KEY."
|
|
(setq tp--reactive-counters
|
|
(plist-put tp--reactive-counters key
|
|
(1+ (plist-get tp--reactive-counters key)))))
|
|
|
|
(defun tp-reactive-counters ()
|
|
"Return public signal and binding scheduler counters."
|
|
(copy-sequence tp--reactive-counters))
|
|
|
|
(defun tp-reactive-reset-counters ()
|
|
"Reset public signal and binding scheduler counters."
|
|
(setq tp--reactive-counters
|
|
(list :invalidated 0 :recomputed 0 :skipped 0
|
|
:subscription-added 0 :subscription-removed 0)))
|
|
|
|
(defun tp--dependency-subscribers (dependency)
|
|
"Return the subscriber table owned by DEPENDENCY."
|
|
(cond ((tp-signal-p dependency) (tp-signal-subscribers dependency))
|
|
((tp-binding-p dependency) (tp-binding-subscribers dependency))
|
|
(t (signal 'wrong-type-argument
|
|
(list '(or tp-signal-p tp-binding-p) dependency)))))
|
|
|
|
(defun tp--subscription-add (dependency binding)
|
|
"Subscribe BINDING to DEPENDENCY."
|
|
(let ((subscribers (tp--dependency-subscribers dependency)))
|
|
(unless (gethash binding subscribers)
|
|
(puthash binding t subscribers)
|
|
(tp--counter-increment :subscription-added))))
|
|
|
|
(defun tp--subscription-remove (dependency binding)
|
|
"Unsubscribe BINDING from DEPENDENCY."
|
|
(let ((subscribers (tp--dependency-subscribers dependency)))
|
|
(when (gethash binding subscribers)
|
|
(remhash binding subscribers)
|
|
(tp--counter-increment :subscription-removed))))
|
|
|
|
(defun tp--sorted-subscribers (dependency)
|
|
"Return DEPENDENCY subscribers ordered by stable binding id."
|
|
(let (bindings)
|
|
(maphash (lambda (binding _present) (push binding bindings))
|
|
(tp--dependency-subscribers dependency))
|
|
(sort bindings (lambda (left right)
|
|
(< (tp-binding-id left) (tp-binding-id right))))))
|
|
|
|
(defun tp--binding-snapshot (binding)
|
|
"Return a rollback snapshot of BINDING."
|
|
(tp--make-binding-snapshot
|
|
:compute (tp-binding-compute binding)
|
|
:equality (tp-binding-equality binding)
|
|
:last-value (tp-binding-last-value binding)
|
|
:initialized-p (tp-binding-initialized-p binding)
|
|
:dependencies (copy-sequence (tp-binding-dependencies binding))
|
|
:dirty (tp-binding-dirty binding)
|
|
:state (tp-binding-state binding)
|
|
:revision (tp-binding-revision binding)
|
|
:lifecycle (tp-binding-lifecycle binding)
|
|
:disposed (tp-binding-disposed binding)))
|
|
|
|
(defun tp--snapshot-binding (binding)
|
|
"Save BINDING once for the active transaction."
|
|
(when (and tp--transaction-active
|
|
(not (memq binding tp--transaction-created-bindings))
|
|
(not (gethash binding tp--transaction-binding-snapshots)))
|
|
(puthash binding (tp--binding-snapshot binding)
|
|
tp--transaction-binding-snapshots)))
|
|
|
|
(defun tp--owner-binding-table (owner &optional create)
|
|
"Return OWNER's binding table, creating it when CREATE is non-nil."
|
|
(or (gethash owner tp--owner-bindings)
|
|
(when create
|
|
(let ((table (make-hash-table :test #'equal)))
|
|
(puthash owner table tp--owner-bindings)
|
|
table))))
|
|
|
|
(defun tp--register-binding (binding)
|
|
"Register BINDING under its owner and key."
|
|
(puthash (tp-binding-key binding) binding
|
|
(tp--owner-binding-table (tp-binding-owner binding) t))
|
|
(cl-pushnew binding tp--bindings :test #'eq))
|
|
|
|
(defun tp--unregister-binding (binding)
|
|
"Remove BINDING from owner and global registries."
|
|
(when-let ((table (tp--owner-binding-table (tp-binding-owner binding))))
|
|
(remhash (tp-binding-key binding) table)
|
|
(when (zerop (hash-table-count table))
|
|
(remhash (tp-binding-owner binding) tp--owner-bindings)))
|
|
(setq tp--bindings (delq binding tp--bindings)))
|
|
|
|
(defun tp--enqueue-binding (binding)
|
|
"Add dirty BINDING to the current transaction queue once."
|
|
(unless (gethash binding tp--transaction-dirty-set)
|
|
(puthash binding t tp--transaction-dirty-set)
|
|
(push binding tp--transaction-dirty-queue)))
|
|
|
|
(defun tp--mark-binding-dirty (binding)
|
|
"Mark live BINDING dirty in the current transaction."
|
|
(when (and (tp-binding-p binding) (not (tp-binding-disposed binding)))
|
|
(tp--snapshot-binding binding)
|
|
(unless (tp-binding-dirty binding)
|
|
(setf (tp-binding-dirty binding) t)
|
|
(tp--counter-increment :invalidated))
|
|
(tp--enqueue-binding binding)))
|
|
|
|
(defun tp--invalidate-subscribers (dependency &optional skip)
|
|
"Dirty DEPENDENCY subscribers except SKIP."
|
|
(dolist (binding (tp--sorted-subscribers dependency))
|
|
(unless (eq binding skip)
|
|
(tp--mark-binding-dirty binding))))
|
|
|
|
(defun tp--record-dependency (dependency)
|
|
"Record DEPENDENCY for the binding currently being computed."
|
|
(when tp--current-binding
|
|
(unless (gethash dependency tp--collected-dependency-set)
|
|
(puthash dependency t tp--collected-dependency-set)
|
|
(push dependency tp--collected-dependencies))))
|
|
|
|
(defun tp--signal-value-in-transaction (signal)
|
|
"Return SIGNAL's candidate or committed value."
|
|
(if tp--transaction-active
|
|
(let ((candidate (gethash signal tp--transaction-signal-values
|
|
tp--reactive-absent)))
|
|
(if (eq candidate tp--reactive-absent)
|
|
(tp-signal-committed-value signal)
|
|
candidate))
|
|
(tp-signal-committed-value signal)))
|
|
|
|
(defun tp--validate-live-signal (signal)
|
|
"Signal an error unless SIGNAL is live."
|
|
(unless (tp-signal-p signal)
|
|
(signal 'wrong-type-argument (list 'tp-signal-p signal)))
|
|
(when (tp-signal-disposed signal)
|
|
(signal 'tp-disposed-signal (list (tp-signal-id signal)))))
|
|
|
|
(defun tp-signal-live-p (signal)
|
|
"Return non-nil when SIGNAL is a live TP signal."
|
|
(and (tp-signal-p signal) (not (tp-signal-disposed signal))))
|
|
|
|
(defun tp--buffer-signal-kill ()
|
|
"Dispose signals scoped to the buffer being killed."
|
|
(let ((signals tp--buffer-signals))
|
|
(setq tp--buffer-signals nil)
|
|
(dolist (signal signals)
|
|
(tp--dispose-signal signal))))
|
|
|
|
(cl-defun tp-signal-create (initial-value &key (equality #'equal) (scope 'global))
|
|
"Create a signal holding INITIAL-VALUE.
|
|
EQUALITY compares writes. SCOPE is `global' or a live buffer."
|
|
(unless (functionp equality)
|
|
(signal 'wrong-type-argument (list 'functionp equality)))
|
|
(unless (or (eq scope 'global) (buffer-live-p scope))
|
|
(signal 'tp-invalid-signal-scope (list scope)))
|
|
(let ((signal (tp--make-signal
|
|
:id (cl-incf tp--signal-id-counter)
|
|
:committed-value initial-value :equality equality
|
|
:subscribers (make-hash-table :test #'eq)
|
|
:scope scope :revision 0)))
|
|
(push signal tp--signals)
|
|
(when (bufferp scope)
|
|
(with-current-buffer scope
|
|
(push signal tp--buffer-signals)
|
|
(add-hook 'kill-buffer-hook #'tp--buffer-signal-kill nil t)))
|
|
signal))
|
|
|
|
(defun tp-signal-peek (signal)
|
|
"Return SIGNAL's effective value without collecting a dependency."
|
|
(tp--validate-live-signal signal)
|
|
(tp--signal-value-in-transaction signal))
|
|
|
|
(defun tp-signal-read (signal)
|
|
"Read SIGNAL and register the current binding as a subscriber."
|
|
(tp--validate-live-signal signal)
|
|
(tp--record-dependency signal)
|
|
(tp--signal-value-in-transaction signal))
|
|
|
|
(defun tp--set-signal-candidate (signal value)
|
|
"Set candidate VALUE for SIGNAL in the active transaction."
|
|
(let ((old (tp--signal-value-in-transaction signal)))
|
|
(unless (funcall (tp-signal-equality signal) old value)
|
|
(when (eq (gethash signal tp--transaction-signal-values
|
|
tp--reactive-absent)
|
|
tp--reactive-absent)
|
|
(push signal tp--transaction-signals))
|
|
(puthash signal value tp--transaction-signal-values)
|
|
(tp--invalidate-subscribers signal)
|
|
(when (and tp--current-binding
|
|
(gethash signal tp--collected-dependency-set))
|
|
(tp--mark-binding-dirty tp--current-binding))))
|
|
value)
|
|
|
|
(defun tp-signal-set (signal value)
|
|
"Set SIGNAL to VALUE transactionally and return VALUE."
|
|
(tp--validate-live-signal signal)
|
|
(if tp--transaction-active
|
|
(tp--set-signal-candidate signal value)
|
|
(tp--call-with-transaction
|
|
(lambda () (tp--set-signal-candidate signal value)))))
|
|
|
|
(defun tp-signal-subscriber-count (signal)
|
|
"Return the number of subscribers attached to SIGNAL.
|
|
Disposed signals return zero."
|
|
(unless (tp-signal-p signal)
|
|
(signal 'wrong-type-argument (list 'tp-signal-p signal)))
|
|
(hash-table-count (tp-signal-subscribers signal)))
|
|
|
|
(defun tp--binding-dependency-path (start target visited)
|
|
"Return a binding path from START to TARGET, avoiding VISITED."
|
|
(cond
|
|
((eq start target) (list target))
|
|
((memq start visited) nil)
|
|
(t
|
|
(cl-loop for dependency in (tp-binding-dependencies start)
|
|
when (tp-binding-p dependency)
|
|
for path = (tp--binding-dependency-path
|
|
dependency target (cons start visited))
|
|
when path return (cons start path)))))
|
|
|
|
(defun tp--stack-cycle-path (target)
|
|
"Return the active compute-stack cycle ending at TARGET."
|
|
(let ((path (reverse tp--binding-compute-stack)))
|
|
(while (and path (not (eq (car path) target)))
|
|
(setq path (cdr path)))
|
|
(append path (list target))))
|
|
|
|
(defun tp--signal-binding-cycle (path)
|
|
"Signal a binding-cycle error for binding PATH."
|
|
(signal 'tp-binding-cycle
|
|
(list (mapcar (lambda (binding)
|
|
(copy-tree (tp-binding-key binding)))
|
|
path))))
|
|
|
|
(defun tp--validate-binding-read (binding &optional computing-only)
|
|
"Validate reading BINDING from the current computation.
|
|
When COMPUTING-ONLY is non-nil, defer old-graph traversal until after a
|
|
dirty target has recomputed."
|
|
(when tp--current-binding
|
|
(when (eq (tp-binding-state binding) 'computing)
|
|
(tp--signal-binding-cycle (tp--stack-cycle-path binding)))
|
|
(unless computing-only
|
|
(when-let ((path (tp--binding-dependency-path
|
|
binding tp--current-binding nil)))
|
|
(tp--signal-binding-cycle (cons tp--current-binding path))))))
|
|
|
|
(defun tp--replace-binding-dependencies (binding dependencies)
|
|
"Replace BINDING dependencies with DEPENDENCIES."
|
|
(let ((old (tp-binding-dependencies binding)))
|
|
(dolist (dependency old)
|
|
(unless (memq dependency dependencies)
|
|
(tp--subscription-remove dependency binding)))
|
|
(dolist (dependency dependencies)
|
|
(unless (memq dependency old)
|
|
(tp--subscription-add dependency binding)))
|
|
(setf (tp-binding-dependencies binding) dependencies)))
|
|
|
|
(defun tp--note-binding-recompute (binding)
|
|
"Record one recomputation of BINDING and reject runaway feedback."
|
|
(let ((count (1+ (gethash binding tp--transaction-recompute-counts 0))))
|
|
(puthash binding count tp--transaction-recompute-counts)
|
|
(when (> count 100)
|
|
(tp--signal-binding-cycle (list binding binding)))))
|
|
|
|
(defun tp--binding-recompute (binding)
|
|
"Recompute dirty BINDING inside the active transaction."
|
|
(tp--snapshot-binding binding)
|
|
(tp--note-binding-recompute binding)
|
|
(let ((requester tp--current-binding)
|
|
(old (tp-binding-last-value binding))
|
|
(initialized (tp-binding-initialized-p binding))
|
|
(tp--current-binding binding)
|
|
(tp--binding-compute-stack (cons binding tp--binding-compute-stack))
|
|
(tp--collected-dependency-set (make-hash-table :test #'eq))
|
|
(tp--collected-dependencies nil))
|
|
(setf (tp-binding-state binding) 'computing
|
|
(tp-binding-dirty binding) nil)
|
|
(let* ((value (funcall (tp-binding-compute binding)))
|
|
(dependencies (nreverse tp--collected-dependencies))
|
|
(changed (or (not initialized)
|
|
(not (funcall (tp-binding-equality binding)
|
|
old value)))))
|
|
(tp--replace-binding-dependencies binding dependencies)
|
|
(setf (tp-binding-state binding) 'clean)
|
|
(tp--counter-increment :recomputed)
|
|
(if changed
|
|
(progn
|
|
(setf (tp-binding-last-value binding) value
|
|
(tp-binding-initialized-p binding) t
|
|
(tp-binding-revision binding)
|
|
(1+ (tp-binding-revision binding)))
|
|
(run-hook-with-args 'tp--binding-changed-functions
|
|
binding old value)
|
|
(tp--invalidate-subscribers binding requester))
|
|
(tp--counter-increment :skipped))
|
|
value)))
|
|
|
|
(defun tp--validate-live-binding (binding)
|
|
"Signal an error unless BINDING is live."
|
|
(unless (tp-binding-p binding)
|
|
(signal 'wrong-type-argument (list 'tp-binding-p binding)))
|
|
(when (tp-binding-disposed binding)
|
|
(signal 'tp-disposed-binding (list (tp-binding-id binding)))))
|
|
|
|
(defun tp-binding-live-p (binding)
|
|
"Return non-nil when BINDING is a live TP binding."
|
|
(and (tp-binding-p binding) (not (tp-binding-disposed binding))))
|
|
|
|
(defun tp-binding-read (binding)
|
|
"Read BINDING's memoized value and collect a dependency."
|
|
(tp--validate-live-binding binding)
|
|
(tp--validate-binding-read binding t)
|
|
(when (tp-binding-dirty binding)
|
|
(if tp--transaction-active
|
|
(tp--binding-recompute binding)
|
|
(tp--call-with-transaction (lambda () (tp--binding-recompute binding)))))
|
|
(tp--validate-binding-read binding)
|
|
(tp--record-dependency binding)
|
|
(tp-binding-last-value binding))
|
|
|
|
(defun tp-binding-subscriber-count (binding)
|
|
"Return the number of bindings depending directly on BINDING.
|
|
Disposed bindings return zero."
|
|
(unless (tp-binding-p binding)
|
|
(signal 'wrong-type-argument (list 'tp-binding-p binding)))
|
|
(hash-table-count (tp-binding-subscribers binding)))
|
|
|
|
(defun tp-binding-dependency-count (binding)
|
|
"Return BINDING's current direct dependency count.
|
|
Disposed bindings return zero."
|
|
(unless (tp-binding-p binding)
|
|
(signal 'wrong-type-argument (list 'tp-binding-p binding)))
|
|
(length (tp-binding-dependencies binding)))
|
|
|
|
(defun tp--validate-binding-options (compute equality lifecycle)
|
|
"Validate binding COMPUTE, EQUALITY, and LIFECYCLE."
|
|
(unless (functionp compute)
|
|
(signal 'wrong-type-argument (list 'functionp compute)))
|
|
(unless (functionp equality)
|
|
(signal 'wrong-type-argument (list 'functionp equality)))
|
|
(unless (memq lifecycle '(delete retain))
|
|
(signal 'tp-reactive-error (list :lifecycle lifecycle))))
|
|
|
|
(defun tp--bind-in-transaction (owner key compute equality lifecycle)
|
|
"Install COMPUTE for OWNER and KEY in the active transaction.
|
|
EQUALITY compares values and LIFECYCLE controls retention."
|
|
(let* ((table (tp--owner-binding-table owner t))
|
|
(binding (gethash key table)))
|
|
(if binding
|
|
(unless (and (eq compute (tp-binding-compute binding))
|
|
(eq equality (tp-binding-equality binding))
|
|
(eq lifecycle (tp-binding-lifecycle binding)))
|
|
(tp--snapshot-binding binding)
|
|
(setf (tp-binding-compute binding) compute
|
|
(tp-binding-equality binding) equality
|
|
(tp-binding-lifecycle binding) lifecycle)
|
|
(tp--mark-binding-dirty binding))
|
|
(setq binding
|
|
(tp--make-binding
|
|
:id (cl-incf tp--binding-id-counter)
|
|
:owner owner :key (copy-tree key) :compute compute
|
|
:equality equality :subscribers (make-hash-table :test #'eq)
|
|
:dirty t :state 'clean :revision 0 :lifecycle lifecycle))
|
|
(tp--register-binding binding)
|
|
(push binding tp--transaction-created-bindings)
|
|
(tp--enqueue-binding binding))
|
|
(when tp--binding-touch-function
|
|
(funcall tp--binding-touch-function binding))
|
|
binding))
|
|
|
|
(cl-defun tp-bind (owner key compute &key (equality #'equal) (lifecycle 'delete))
|
|
"Idempotently install COMPUTE on OWNER under namespaced KEY.
|
|
EQUALITY suppresses unchanged downstream updates. LIFECYCLE is `delete'
|
|
or `retain'."
|
|
(when (null owner)
|
|
(signal 'tp-reactive-error (list :owner owner)))
|
|
(when (null key)
|
|
(signal 'tp-reactive-error (list :binding-key key)))
|
|
(tp--validate-binding-options compute equality lifecycle)
|
|
(if tp--transaction-active
|
|
(tp--bind-in-transaction owner key compute equality lifecycle)
|
|
(tp--call-with-transaction
|
|
(lambda () (tp--bind-in-transaction
|
|
owner key compute equality lifecycle)))))
|
|
|
|
(defun tp--detach-binding-dependencies (binding)
|
|
"Remove BINDING from all dependency subscriber tables."
|
|
(dolist (dependency (tp-binding-dependencies binding))
|
|
(tp--subscription-remove dependency binding))
|
|
(setf (tp-binding-dependencies binding) nil))
|
|
|
|
(defun tp--detach-binding-subscribers (binding)
|
|
"Detach every direct subscriber from BINDING."
|
|
(dolist (subscriber (tp--sorted-subscribers binding))
|
|
(tp--snapshot-binding subscriber)
|
|
(setf (tp-binding-dependencies subscriber)
|
|
(delq binding (tp-binding-dependencies subscriber))
|
|
(tp-binding-dirty subscriber) t)
|
|
(tp--subscription-remove binding subscriber)))
|
|
|
|
(defun tp--dispose-binding (binding)
|
|
"Dispose live BINDING without starting a transaction."
|
|
(unless (tp-binding-disposed binding)
|
|
(tp--snapshot-binding binding)
|
|
(tp--detach-binding-dependencies binding)
|
|
(tp--detach-binding-subscribers binding)
|
|
(tp--unregister-binding binding)
|
|
(setf (tp-binding-disposed binding) t
|
|
(tp-binding-dirty binding) nil
|
|
(tp-binding-state binding) 'disposed)))
|
|
|
|
(defun tp-binding-dispose-owner (owner)
|
|
"Dispose every binding installed on OWNER and return the count."
|
|
(let ((bindings (when-let ((table (tp--owner-binding-table owner)))
|
|
(let (items)
|
|
(maphash (lambda (_key binding) (push binding items)) table)
|
|
(sort items (lambda (left right)
|
|
(< (tp-binding-id left)
|
|
(tp-binding-id right))))))))
|
|
(if tp--transaction-active
|
|
(dolist (binding bindings) (tp--dispose-binding binding))
|
|
(tp--call-with-transaction
|
|
(lambda () (dolist (binding bindings) (tp--dispose-binding binding)))))
|
|
(length bindings)))
|
|
|
|
(defun tp-binding-owner-bindings (owner)
|
|
"Return OWNER's live bindings ordered by stable binding id."
|
|
(when-let ((table (tp--owner-binding-table owner)))
|
|
(let (bindings)
|
|
(maphash (lambda (_key binding) (push binding bindings)) table)
|
|
(sort bindings (lambda (left right)
|
|
(< (tp-binding-id left) (tp-binding-id right)))))))
|
|
|
|
(defun tp-binding-dispose (binding)
|
|
"Dispose BINDING and detach all of its graph edges."
|
|
(tp--validate-live-binding binding)
|
|
(if tp--transaction-active
|
|
(tp--dispose-binding binding)
|
|
(tp--call-with-transaction (lambda () (tp--dispose-binding binding))))
|
|
nil)
|
|
|
|
(defun tp--transaction-extension (key &optional create)
|
|
"Return transaction extension state for KEY.
|
|
When CREATE is non-nil, install and return a fresh hash table when absent."
|
|
(unless tp--transaction-active
|
|
(signal 'tp-reactive-error (list :outside-transaction key)))
|
|
(or (gethash key tp--transaction-extensions)
|
|
(when create
|
|
(let ((state (make-hash-table :test #'eq)))
|
|
(puthash key state tp--transaction-extensions)
|
|
state))))
|
|
|
|
(defun tp--transaction-counter-delta (key)
|
|
"Return active transaction counter delta for KEY."
|
|
(if tp--transaction-counter-start
|
|
(- (plist-get tp--reactive-counters key)
|
|
(plist-get tp--transaction-counter-start key))
|
|
0))
|
|
|
|
(defun tp--enqueue-after-commit (function)
|
|
"Run FUNCTION after the active outer transaction has exited."
|
|
(unless tp--transaction-active
|
|
(signal 'tp-reactive-error (list :outside-transaction function)))
|
|
(push function tp--transaction-after-commit-callbacks))
|
|
|
|
;;;###autoload
|
|
(defun tp-transaction-participate (key publish rollback)
|
|
"Register rollback-capable PUBLISH work under transaction-local KEY.
|
|
PUBLISH runs after every affected surface has published its candidate buffer
|
|
and side state, but before the transaction commits its source values. If this
|
|
or any later publication step fails, ROLLBACK runs in reverse publication
|
|
order. Both functions take no arguments. KEY must be unique in the outer
|
|
transaction."
|
|
(unless tp--transaction-active
|
|
(signal 'tp-reactive-error (list :participant-outside-transaction key)))
|
|
(unless key
|
|
(signal 'tp-reactive-error (list :participant-key key)))
|
|
(unless (functionp publish)
|
|
(signal 'wrong-type-argument (list 'functionp publish)))
|
|
(unless (functionp rollback)
|
|
(signal 'wrong-type-argument (list 'functionp rollback)))
|
|
(when (member key tp--transaction-participant-keys)
|
|
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
|
|
(push (copy-tree key) tp--transaction-participant-keys)
|
|
(push (tp--make-transaction-participant
|
|
:key (copy-tree key) :publish publish :rollback rollback)
|
|
tp--transaction-participants)
|
|
key)
|
|
|
|
(defun tp--publish-transaction-participants ()
|
|
"Publish registered transaction participants in declaration order."
|
|
(dolist (participant (nreverse tp--transaction-participants))
|
|
(push participant tp--transaction-published-participants)
|
|
(funcall (tp--transaction-participant-publish participant))))
|
|
|
|
(defun tp--rollback-transaction-participants ()
|
|
"Rollback published participants and return any failures."
|
|
(let (failures)
|
|
(dolist (participant tp--transaction-published-participants)
|
|
(condition-case failure
|
|
(funcall (tp--transaction-participant-rollback participant))
|
|
(error
|
|
(push (list :key (tp--transaction-participant-key participant)
|
|
:error failure)
|
|
failures))))
|
|
(nreverse failures)))
|
|
|
|
(defun tp--dequeue-dirty-binding ()
|
|
"Return and remove the next queued dirty binding."
|
|
(let (binding)
|
|
(while (and tp--transaction-dirty-queue (null binding))
|
|
(let ((candidate (pop tp--transaction-dirty-queue)))
|
|
(when (gethash candidate tp--transaction-dirty-set)
|
|
(remhash candidate tp--transaction-dirty-set)
|
|
(setq binding candidate))))
|
|
binding))
|
|
|
|
(defun tp--flush-dirty-bindings ()
|
|
"Recompute the transaction's exact dirty closure."
|
|
(let (binding)
|
|
(while (setq binding (tp--dequeue-dirty-binding))
|
|
(when (and (tp-binding-live-p binding) (tp-binding-dirty binding))
|
|
(tp--binding-recompute binding)))))
|
|
|
|
(defun tp--restore-binding (binding snapshot)
|
|
"Restore BINDING fields from SNAPSHOT."
|
|
(setf (tp-binding-compute binding) (tp--binding-snapshot-compute snapshot)
|
|
(tp-binding-equality binding) (tp--binding-snapshot-equality snapshot)
|
|
(tp-binding-last-value binding) (tp--binding-snapshot-last-value snapshot)
|
|
(tp-binding-initialized-p binding)
|
|
(tp--binding-snapshot-initialized-p snapshot)
|
|
(tp-binding-dependencies binding)
|
|
(copy-sequence (tp--binding-snapshot-dependencies snapshot))
|
|
(tp-binding-dirty binding) (tp--binding-snapshot-dirty snapshot)
|
|
(tp-binding-state binding) (tp--binding-snapshot-state snapshot)
|
|
(tp-binding-revision binding) (tp--binding-snapshot-revision snapshot)
|
|
(tp-binding-lifecycle binding) (tp--binding-snapshot-lifecycle snapshot)
|
|
(tp-binding-disposed binding) (tp--binding-snapshot-disposed snapshot)))
|
|
|
|
(defun tp--rollback-bindings ()
|
|
"Restore all bindings touched by the active transaction."
|
|
(let (snapshots)
|
|
(maphash (lambda (binding snapshot)
|
|
(push (cons binding snapshot) snapshots))
|
|
tp--transaction-binding-snapshots)
|
|
(dolist (binding (append tp--transaction-created-bindings
|
|
(mapcar #'car snapshots)))
|
|
(tp--detach-binding-dependencies binding))
|
|
(dolist (binding tp--transaction-created-bindings)
|
|
(tp--unregister-binding binding)
|
|
(setf (tp-binding-disposed binding) t
|
|
(tp-binding-state binding) 'disposed))
|
|
(dolist (entry snapshots)
|
|
(pcase-let ((`(,binding . ,snapshot) entry))
|
|
(tp--restore-binding binding snapshot)
|
|
(unless (tp-binding-disposed binding)
|
|
(tp--register-binding binding)
|
|
(dolist (dependency (tp-binding-dependencies binding))
|
|
(tp--subscription-add dependency binding)))))))
|
|
|
|
(defun tp--commit-signal-values ()
|
|
"Commit candidate signal values after a successful flush."
|
|
(dolist (signal (nreverse tp--transaction-signals))
|
|
(setf (tp-signal-committed-value signal)
|
|
(gethash signal tp--transaction-signal-values)
|
|
(tp-signal-revision signal) (1+ (tp-signal-revision signal)))))
|
|
|
|
(defun tp--call-with-transaction (function)
|
|
"Call FUNCTION in one atomic signal and binding transaction."
|
|
(if tp--transaction-active
|
|
(funcall function)
|
|
(let (after-commit result)
|
|
(setq result
|
|
(let ((tp--transaction-active t)
|
|
(tp--transaction-signal-values
|
|
(make-hash-table :test #'eq))
|
|
(tp--transaction-signals nil)
|
|
(tp--transaction-dirty-set (make-hash-table :test #'eq))
|
|
(tp--transaction-dirty-queue nil)
|
|
(tp--transaction-binding-snapshots
|
|
(make-hash-table :test #'eq))
|
|
(tp--transaction-created-bindings nil)
|
|
(tp--transaction-recompute-counts
|
|
(make-hash-table :test #'eq))
|
|
(tp--transaction-extensions (make-hash-table :test #'eq))
|
|
(tp--transaction-after-commit-callbacks nil)
|
|
(tp--transaction-participants nil)
|
|
(tp--transaction-participant-keys nil)
|
|
(tp--transaction-published-participants nil)
|
|
(counter-snapshot (copy-sequence tp--reactive-counters))
|
|
(tp--transaction-counter-start nil)
|
|
success transaction-result rollback-failures)
|
|
(setq tp--transaction-counter-start counter-snapshot)
|
|
(unwind-protect
|
|
(progn
|
|
(setq transaction-result (funcall function))
|
|
(tp--flush-dirty-bindings)
|
|
(run-hooks 'tp--transaction-publish-functions)
|
|
(tp--publish-transaction-participants)
|
|
(tp--commit-signal-values)
|
|
(setq success t)
|
|
transaction-result)
|
|
(unless success
|
|
(let ((inhibit-quit t))
|
|
(setq rollback-failures
|
|
(tp--rollback-transaction-participants))
|
|
(run-hooks 'tp--transaction-rollback-functions)
|
|
(tp--rollback-bindings)
|
|
(setq tp--reactive-counters counter-snapshot)
|
|
(run-hooks 'tp--transaction-rollback-final-functions)
|
|
(when rollback-failures
|
|
(signal 'tp-reactive-error
|
|
(list :participant-rollback-failed
|
|
rollback-failures))))))
|
|
(when success
|
|
(run-hooks 'tp--transaction-committed-functions)
|
|
(setq after-commit
|
|
(nreverse tp--transaction-after-commit-callbacks)))
|
|
transaction-result))
|
|
(dolist (callback after-commit) (funcall callback))
|
|
result)))
|
|
|
|
;;;###autoload
|
|
(defmacro tp-with-transaction (&rest body)
|
|
"Evaluate BODY in one atomic signal and binding transaction."
|
|
(declare (indent 0) (debug t))
|
|
`(tp--call-with-transaction (lambda () ,@body)))
|
|
|
|
(defun tp--variable-signal-key (symbol scope)
|
|
"Return the adapter key for SYMBOL and SCOPE."
|
|
(cons symbol scope))
|
|
|
|
(defun tp--variable-signal-watcher (symbol new-value operation where)
|
|
"Forward SYMBOL's NEW-VALUE write into its exact signal adapter.
|
|
OPERATION and WHERE follow the standard variable watcher protocol."
|
|
(when (eq operation 'set)
|
|
(when-let ((signal (gethash (tp--variable-signal-key
|
|
symbol (or where 'global))
|
|
tp--variable-signals)))
|
|
(when (tp-signal-live-p signal)
|
|
(tp-signal-set signal new-value)))))
|
|
|
|
(defun tp--variable-signal-initial-value (symbol scope)
|
|
"Return SYMBOL's initial adapter value in SCOPE."
|
|
(if (eq scope 'global)
|
|
(if (default-boundp symbol) (default-value symbol) nil)
|
|
(with-current-buffer scope
|
|
(if (boundp symbol) (symbol-value symbol) nil))))
|
|
|
|
(defun tp-variable-signal (symbol &optional buffer)
|
|
"Return the signal adapting SYMBOL globally or in BUFFER."
|
|
(unless (symbolp symbol)
|
|
(signal 'wrong-type-argument (list 'symbolp symbol)))
|
|
(when (and buffer (not (buffer-live-p buffer)))
|
|
(signal 'tp-invalid-signal-scope (list buffer)))
|
|
(let* ((scope (or buffer 'global))
|
|
(key (tp--variable-signal-key symbol scope)))
|
|
(or (gethash key tp--variable-signals)
|
|
(let ((signal (tp-signal-create
|
|
(tp--variable-signal-initial-value symbol scope)
|
|
:scope scope)))
|
|
(setf (tp-signal-adapter-key signal) key)
|
|
(puthash key signal tp--variable-signals)
|
|
(unless (memq symbol tp--variable-signal-watched)
|
|
(add-variable-watcher symbol #'tp--variable-signal-watcher)
|
|
(push symbol tp--variable-signal-watched))
|
|
signal))))
|
|
|
|
(defun tp--symbol-has-variable-signal-p (symbol)
|
|
"Return non-nil when SYMBOL still owns an adapter signal."
|
|
(let ((found nil))
|
|
(maphash (lambda (key _signal)
|
|
(when (eq (car key) symbol) (setq found t)))
|
|
tp--variable-signals)
|
|
found))
|
|
|
|
(defun tp--dispose-signal (signal)
|
|
"Dispose SIGNAL and detach its graph and adapter state."
|
|
(unless (tp-signal-disposed signal)
|
|
(dolist (binding (tp--sorted-subscribers signal))
|
|
(setf (tp-binding-dependencies binding)
|
|
(delq signal (tp-binding-dependencies binding))
|
|
(tp-binding-dirty binding) t))
|
|
(clrhash (tp-signal-subscribers signal))
|
|
(when-let ((key (tp-signal-adapter-key signal)))
|
|
(remhash key tp--variable-signals)
|
|
(let ((symbol (car key)))
|
|
(unless (tp--symbol-has-variable-signal-p symbol)
|
|
(remove-variable-watcher symbol #'tp--variable-signal-watcher)
|
|
(setq tp--variable-signal-watched
|
|
(delq symbol tp--variable-signal-watched)))))
|
|
(when-let ((scope (and (bufferp (tp-signal-scope signal))
|
|
(tp-signal-scope signal))))
|
|
(when (buffer-live-p scope)
|
|
(with-current-buffer scope
|
|
(setq tp--buffer-signals (delq signal tp--buffer-signals)))))
|
|
(setf (tp-signal-disposed signal) t)
|
|
(setq tp--signals (delq signal tp--signals))))
|
|
|
|
(defun tp-signal-dispose (signal)
|
|
"Dispose SIGNAL, detach its subscriptions, and return nil."
|
|
(unless (tp-signal-p signal)
|
|
(signal 'wrong-type-argument (list 'tp-signal-p signal)))
|
|
(when tp--transaction-active
|
|
(signal 'tp-reactive-error (list :dispose-during-transaction)))
|
|
(tp--dispose-signal signal)
|
|
nil)
|
|
|
|
(defun tp--reactive-graph-reset ()
|
|
"Clear all signal, binding, adapter, and scheduler state."
|
|
(when tp--transaction-active
|
|
(signal 'tp-reactive-error (list :reset-during-transaction)))
|
|
(dolist (binding tp--bindings)
|
|
(tp--detach-binding-dependencies binding)
|
|
(clrhash (tp-binding-subscribers binding))
|
|
(setf (tp-binding-disposed binding) t
|
|
(tp-binding-state binding) 'disposed))
|
|
(dolist (signal (copy-sequence tp--signals))
|
|
(tp--dispose-signal signal))
|
|
(clrhash tp--owner-bindings)
|
|
(clrhash tp--variable-signals)
|
|
(setq tp--bindings nil
|
|
tp--signals nil
|
|
tp--variable-signal-watched nil)
|
|
(tp-reactive-reset-counters))
|
|
|
|
(defvar tp-reactive-deps nil
|
|
"Alist mapping reactive variables to dependent layers.
|
|
Each element: (VAR-SYMBOL . ((LAYER-NAME . REACTIVE-PROPS) ...)).")
|
|
|
|
(defvar tp-layer-watchers nil
|
|
"Alist of layer watchers: (LAYER-NAME . ((VAR-SYMBOL . CALLBACK) ...)).")
|
|
|
|
(defvar tp-reactive-observer-errors nil
|
|
"Structured observer failures, newest first.
|
|
Each entry is a plist containing `:kind', `:layer', `:symbol',
|
|
`:condition', `:new-value', and `:old-value'. Watcher failures are
|
|
recorded here and reported, but do not block the managed update.")
|
|
|
|
(defvar tp-layer-computed nil
|
|
"Alist of computed properties: (LAYER-NAME . ((VAR-SYMBOL . COMPUTE-FN) ...)).")
|
|
|
|
(defvar tp-layer-data nil
|
|
"Alist of data variables: (LAYER-NAME . (VAR-SYMBOL ...)).")
|
|
|
|
(defvar tp--batch-update-pending nil
|
|
"Queue of deferred reactive buffer re-renders.
|
|
Each entry is a list (LAYER-NAME CHANGED-SYMBOLS WHERE TP-TEXT-AFFECTED).
|
|
Entries are created and widened by `tp--queue-batch-update'.")
|
|
|
|
(defvar tp--layer-buffers (make-hash-table :test 'equal)
|
|
"Hash table mapping layer names to buffers showing their regions.
|
|
Keys are layer names; values are lists of buffers registered via
|
|
`tp-reactive--register-layer-buffer'. Reactive updates walk only
|
|
these buffers instead of scanning `buffer-list' (see
|
|
`tp-reactive-layer-buffers'). A key holding an empty list means
|
|
\"known: no buffer shows this layer\", which is distinct from an
|
|
absent key (`unknown').")
|
|
|
|
(defvar tp--layer-buffers-hook-installed nil
|
|
"Non-nil once the registry's `kill-buffer-hook' pruner is installed.")
|
|
|
|
(defun tp-reactive--install-kill-buffer-hook ()
|
|
"Install the global `kill-buffer-hook' pruning the buffer registry.
|
|
Idempotent; guarded by `tp--layer-buffers-hook-installed'."
|
|
(unless tp--layer-buffers-hook-installed
|
|
(add-hook 'kill-buffer-hook #'tp-reactive--prune-killed-buffer)
|
|
(setq tp--layer-buffers-hook-installed t)))
|
|
|
|
(defun tp-reactive--prune-killed-buffer ()
|
|
"Drop the buffer being killed from `tp--layer-buffers'.
|
|
Runs on `kill-buffer-hook' with the dying buffer current. The layer
|
|
entries themselves are kept: an entry left with an empty list means
|
|
\"known: no buffer shows this layer\", not `unknown'."
|
|
(let ((buf (current-buffer)))
|
|
(maphash (lambda (layer bufs)
|
|
(when (memq buf bufs)
|
|
(puthash layer (delq buf bufs) tp--layer-buffers)))
|
|
tp--layer-buffers)))
|
|
|
|
(defun tp-reactive--register-layer-buffer (layer-name buffer)
|
|
"Register BUFFER as showing regions of layer LAYER-NAME.
|
|
Idempotent: registering the same live BUFFER again keeps a single
|
|
entry. Dead buffers and a nil LAYER-NAME are ignored. Installs the
|
|
`kill-buffer-hook' pruner on first use. See
|
|
`tp-reactive-layer-buffers' for the consumer side of the registry."
|
|
(when (and layer-name (buffer-live-p buffer))
|
|
(tp-reactive--install-kill-buffer-hook)
|
|
(let ((bufs (gethash layer-name tp--layer-buffers)))
|
|
(unless (memq buffer bufs)
|
|
(puthash layer-name (cons buffer bufs) tp--layer-buffers)))))
|
|
|
|
(defun tp-reactive--unregister-layer-buffer (layer-name buffer)
|
|
"Remove BUFFER from LAYER-NAME's registry entry when it is known."
|
|
(let ((buffers (gethash layer-name tp--layer-buffers 'unknown)))
|
|
(unless (eq buffers 'unknown)
|
|
(puthash layer-name (delq buffer buffers) tp--layer-buffers))))
|
|
|
|
(defun tp-reactive-layer-buffers (layer-name)
|
|
"Return the live buffers registered as showing layer LAYER-NAME.
|
|
Return a list of live buffers - possibly empty, meaning \"known: no
|
|
buffer shows this layer\" - or the symbol `unknown' when LAYER-NAME
|
|
has no registry entry at all. Killed buffers still recorded in the
|
|
registry are dropped lazily by this accessor.
|
|
|
|
KNOWN GAP: inserting an already-propertized STRING into a buffer
|
|
bypasses the buffer operations that register buffers, so such a
|
|
buffer is missing here until a reactive update's full-scan fallback
|
|
finds it or `tp-reactive-track-buffer' is called on it."
|
|
(let ((bufs (gethash layer-name tp--layer-buffers 'unknown)))
|
|
(if (eq bufs 'unknown)
|
|
'unknown
|
|
(let ((live (cl-remove-if-not #'buffer-live-p bufs)))
|
|
(unless (= (length live) (length bufs))
|
|
(puthash layer-name live tp--layer-buffers))
|
|
live))))
|
|
|
|
(defun tp-reactive--buffer-layer-names (&optional buffer)
|
|
"Return the layer names present in BUFFER, in buffer order.
|
|
BUFFER defaults to the current buffer; a dead BUFFER yields nil.
|
|
Stack-aware: a layer counts as present when its name is the direct
|
|
`tp-name' text property of a run (the rendered top layer) or the
|
|
`tp-name' of any layer plist inside the run's `tp-layers'
|
|
stack-storage property (layers buried below the top, or hidden - see
|
|
tp-stack.el). The `tp-layers' value is read as a plain list of
|
|
plists, so this helper stays below the stack module. Names are
|
|
deduplicated with `equal'. This is the shared scan behind
|
|
`tp-reactive-track-buffer' and the anonymous-layer GC's liveness
|
|
test `tp--buffer-has-layer-region-p'."
|
|
(let ((buf (or buffer (current-buffer)))
|
|
(found nil))
|
|
(when (buffer-live-p buf)
|
|
(tp--map-intervals
|
|
buf nil nil
|
|
(lambda (_start _end props)
|
|
(let ((direct (plist-get props 'tp-name)))
|
|
(when (and direct (not (member direct found)))
|
|
(push direct found)))
|
|
(dolist (layer (plist-get props 'tp-layers))
|
|
(let ((name (plist-get layer 'tp-name)))
|
|
(when (and name (not (member name found)))
|
|
(push name found)))))))
|
|
(nreverse found)))
|
|
|
|
;;;###autoload
|
|
(defun tp-reactive-track-buffer (&optional buffer)
|
|
"Scan BUFFER for layer regions and register it in the buffer registry.
|
|
BUFFER defaults to the current buffer. Walk BUFFER's text-property
|
|
runs and register BUFFER for every layer name found - rendered top
|
|
layers (direct `tp-name') as well as layers inside `tp-layers' stack
|
|
storage (buried below another layer, or hidden) - so reactive updates
|
|
visit it without a full `buffer-list' scan.
|
|
|
|
Call this after inserting an already-propertized string into a
|
|
buffer: string application bypasses the buffer operations that
|
|
register buffers (see `tp-reactive-layer-buffers'), and this command
|
|
closes that gap. Return the list of layer names registered, in
|
|
buffer order."
|
|
(interactive)
|
|
(let* ((buf (or buffer (current-buffer)))
|
|
(found (tp-reactive--buffer-layer-names buf)))
|
|
(dolist (name found)
|
|
(tp-reactive--register-layer-buffer name buf))
|
|
(when (called-interactively-p 'interactive)
|
|
(message "tp: tracking %d layer(s) in %s"
|
|
(length found) (buffer-name buf)))
|
|
found))
|
|
|
|
(defvar tp--batch-update-active nil
|
|
"When non-nil, we are inside a `tp-with-batch-updates' form.")
|
|
|
|
(defvar tp--reactive-updating nil
|
|
"Non-nil while a reactive update is being applied.
|
|
Used as a reentrancy guard: when a variable is set from within an
|
|
update (a computed variable being written, or the tp-text two-way
|
|
sync), the nested change still updates the variable, but its
|
|
re-render is queued in `tp--batch-update-pending' and flushed after
|
|
the outermost update completes instead of recursing.")
|
|
|
|
(defun tp--queue-batch-update (layer-name symbol where tp-text-affected)
|
|
"Queue a deferred re-render of LAYER-NAME in `tp--batch-update-pending'.
|
|
SYMBOL is the changed variable, WHERE the buffer for buffer-local
|
|
changes (nil for global ones), TP-TEXT-AFFECTED non-nil when the
|
|
change touches the layer's `tp-text'. When the layer already has a
|
|
pending entry, the entry is widened to the union of both changes:
|
|
SYMBOL is added, TP-TEXT-AFFECTED is sticky (once set it stays set)
|
|
and WHERE widens to nil (all buffers) as soon as two changes disagree
|
|
on it."
|
|
(let ((existing (assoc layer-name tp--batch-update-pending)))
|
|
(if existing
|
|
(progn
|
|
(unless (memq symbol (nth 1 existing))
|
|
(setf (nth 1 existing) (cons symbol (nth 1 existing))))
|
|
(unless (eq (nth 2 existing) where)
|
|
(setf (nth 2 existing) nil))
|
|
(when tp-text-affected
|
|
(setf (nth 3 existing) t)))
|
|
(push (list layer-name (list symbol) where (and tp-text-affected t))
|
|
tp--batch-update-pending))))
|
|
|
|
(defun tp--register-reactive-deps (layer-name reactive-symbols props)
|
|
"Register REACTIVE-SYMBOLS as dependencies for LAYER-NAME.
|
|
PROPS is the original property specification with reactive symbols.
|
|
Only the reactive portions of the properties are stored for each variable."
|
|
;; Register each reactive symbol's dependency with only its relevant properties
|
|
(dolist (rsym reactive-symbols)
|
|
(let* ((var-sym (tp--reactive-var-symbol rsym))
|
|
;; Extract only the properties that use this specific reactive variable
|
|
(reactive-props (tp--extract-reactive-props props rsym))
|
|
(existing (assoc var-sym tp-reactive-deps)))
|
|
(if existing
|
|
;; Update or add this layer to existing dependencies
|
|
(let ((layer-entry (assoc layer-name (cdr existing))))
|
|
(if layer-entry
|
|
;; Update existing entry with new reactive-props
|
|
(setf (cdr layer-entry) reactive-props)
|
|
;; Add new layer entry
|
|
(push (cons layer-name reactive-props) (cdr existing))))
|
|
;; Create new dependency entry and add watcher
|
|
(push (cons var-sym (list (cons layer-name reactive-props))) tp-reactive-deps)
|
|
;; Add variable watcher for this variable
|
|
(unless (boundp var-sym) (set var-sym nil))
|
|
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))
|
|
|
|
(defun tp--unregister-reactive-deps (layer-name)
|
|
"Unregister all reactive dependencies for LAYER-NAME."
|
|
;; Collect variables that need watcher removal
|
|
(let ((vars-to-clean nil))
|
|
;; First pass: remove layer from dependencies and collect empty vars
|
|
(dolist (dep tp-reactive-deps)
|
|
(let ((var-sym (car dep)))
|
|
(setf (cdr dep) (assq-delete-all layer-name (cdr dep)))
|
|
;; If no more dependencies, mark for watcher removal
|
|
(when (null (cdr dep))
|
|
(push var-sym vars-to-clean))))
|
|
;; Remove watchers for variables with no dependencies
|
|
(dolist (var-sym vars-to-clean)
|
|
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
|
|
;; Clean up empty dependency entries
|
|
(setq tp-reactive-deps
|
|
(cl-remove-if (lambda (dep) (null (cdr dep))) tp-reactive-deps))
|
|
;; Also clean up layer watchers, computed properties, and data
|
|
(tp--unregister-layer-watchers layer-name)
|
|
(tp--unregister-layer-computed layer-name)
|
|
(tp--unregister-layer-data layer-name)
|
|
;; Drop the layer's buffer-registry entry: an undefined (or about to
|
|
;; be redefined) layer must not linger as stale "known" state; the
|
|
;; next update or refresh falls back to a learning full scan.
|
|
(remhash layer-name tp--layer-buffers))
|
|
|
|
(defun tp--layer-has-reactive-deps-p (layer-name)
|
|
"Return non-nil if LAYER-NAME has reactive dependencies registered.
|
|
Layers with reactive deps need tp-name for reactive tracking."
|
|
(cl-some (lambda (dep)
|
|
(assoc layer-name (cdr dep)))
|
|
tp-reactive-deps))
|
|
|
|
(defvar tp--reactive-update-function nil
|
|
"Function applying a reactive update to layer definitions and buffers.
|
|
Installed by tp-render.el. Called with (LAYER-NAME REACTIVE-PROPS
|
|
SYMBOL NEWVAL WHERE OVERRIDE-ALIST) after the user watch callbacks
|
|
have run. When nil, variable changes only invoke watch callbacks and
|
|
no re-rendering happens.")
|
|
|
|
(defun tp--reactive-variable-watcher (symbol newval operation where)
|
|
"Watcher function called when a reactive variable changes.
|
|
SYMBOL is the variable that changed.
|
|
NEWVAL is the new value being set.
|
|
OPERATION is the type of operation (set, let, unlet, makunbound, defvaralias).
|
|
WHERE indicates where the variable was set:
|
|
- nil for global `setq' or `set'
|
|
- a buffer for `setq-local'
|
|
Updates all layers that depend on this variable.
|
|
|
|
Only `set' operations trigger updates because:
|
|
- `let'/`unlet': Temporary bindings that will be restored, no need to update UI
|
|
- `makunbound': Variable is being undefined, not a value change
|
|
- `defvaralias': Aliasing, the actual value change will trigger a separate `set'
|
|
|
|
When `tp--batch-update-active' is non-nil, buffer updates are deferred until
|
|
the batch completes. Layer definitions are still updated immediately.
|
|
|
|
Uses `tp--equal-including-string-properties' for comparison to properly detect
|
|
changes in text properties when the text content is the same.
|
|
|
|
The actual recomputation and buffer re-rendering is delegated to
|
|
`tp--reactive-update-function', installed by tp-render.el."
|
|
(when (and (not (tp--equal-including-string-properties
|
|
(when (boundp symbol)
|
|
(symbol-value symbol))
|
|
newval))
|
|
(eq operation 'set))
|
|
(tp-debug-log "Variable %s changed: %S -> %S (where: %s)"
|
|
symbol (when (boundp symbol) (symbol-value symbol)) newval
|
|
(if where (buffer-name where) "global"))
|
|
(let ((deps (cdr (assoc symbol tp-reactive-deps)))
|
|
(oldval (when (boundp symbol) (symbol-value symbol)))
|
|
;; Create override alist with the new value
|
|
;; (watcher is called before the variable is actually updated)
|
|
(override-alist (list (cons symbol newval))))
|
|
(dolist (dep deps)
|
|
(let ((layer-name (car dep))
|
|
;; Get the reactive props stored directly in the dependency
|
|
(reactive-props (cdr dep)))
|
|
;; Call user-defined watch callbacks for this layer
|
|
(tp--invoke-layer-watchers layer-name symbol newval oldval)
|
|
;; Delegate recomputation and re-rendering to the update engine
|
|
(when tp--reactive-update-function
|
|
(funcall tp--reactive-update-function
|
|
layer-name reactive-props symbol newval
|
|
where override-alist)))))))
|
|
|
|
(defun tp--invoke-layer-watchers (layer-name symbol newval oldval)
|
|
"Invoke all registered watcher callbacks for LAYER-NAME watching SYMBOL.
|
|
NEWVAL is the new value, OLDVAL is the old value."
|
|
(when-let ((watchers (cdr (assoc layer-name tp-layer-watchers))))
|
|
(dolist (watcher watchers)
|
|
(let ((watch-sym (car watcher))
|
|
(callback (cdr watcher)))
|
|
(when (eq watch-sym symbol)
|
|
(tp-debug-log " Invoking watcher for %s on %s" watch-sym layer-name)
|
|
(condition-case err
|
|
(funcall callback newval oldval layer-name)
|
|
(error
|
|
(push (list :kind 'watcher
|
|
:layer layer-name
|
|
:symbol watch-sym
|
|
:condition err
|
|
:new-value newval
|
|
:old-value oldval)
|
|
tp-reactive-observer-errors)
|
|
(message "tp: watcher error for %s watching %s: %s"
|
|
layer-name watch-sym err))))))))
|
|
|
|
(defun tp--register-layer-watchers (layer-name watchers)
|
|
"Register WATCHERS for LAYER-NAME.
|
|
WATCHERS is a list of (VAR-SYMBOL CALLBACK) pairs."
|
|
(when watchers
|
|
(let ((watcher-pairs
|
|
(mapcar (lambda (watcher)
|
|
(cons (car watcher) (cadr watcher)))
|
|
watchers)))
|
|
(if (assoc layer-name tp-layer-watchers)
|
|
(setf (cdr (assoc layer-name tp-layer-watchers)) watcher-pairs)
|
|
(push (cons layer-name watcher-pairs) tp-layer-watchers)))))
|
|
|
|
(defun tp--register-layer-computed (layer-name computed)
|
|
"Register COMPUTED variable definitions for LAYER-NAME.
|
|
COMPUTED is a list of (VAR-SYMBOL COMPUTE-FN) pairs."
|
|
(when computed
|
|
(let ((computed-pairs
|
|
(mapcar (lambda (comp)
|
|
(cons (car comp) (cadr comp)))
|
|
computed)))
|
|
(if (assoc layer-name tp-layer-computed)
|
|
(setf (cdr (assoc layer-name tp-layer-computed)) computed-pairs)
|
|
(push (cons layer-name computed-pairs) tp-layer-computed)))))
|
|
|
|
(defun tp--unregister-layer-watchers (layer-name)
|
|
"Unregister all watchers for LAYER-NAME."
|
|
(setq tp-layer-watchers (assq-delete-all layer-name tp-layer-watchers)))
|
|
|
|
(defun tp--unregister-layer-computed (layer-name)
|
|
"Unregister all computed properties for LAYER-NAME."
|
|
(setq tp-layer-computed (assq-delete-all layer-name tp-layer-computed)))
|
|
|
|
(defun tp--apply-initial-computed (compute)
|
|
"Apply initial computed values using COMPUTE definitions.
|
|
COMPUTE is a list of (VAR-SYMBOL COMPUTE-FN) pairs.
|
|
Sets the global variables to their computed values.
|
|
A compute function returning nil is a legitimate result. Compute
|
|
errors propagate because a skipped value would leave stale state."
|
|
(dolist (comp compute)
|
|
(let* ((var-sym (car comp))
|
|
(compute-fn (cadr comp))
|
|
(val (funcall compute-fn)))
|
|
(set var-sym val))))
|
|
|
|
(defun tp--data-var-symbol (data-entry)
|
|
"Extract the variable symbol from DATA-ENTRY.
|
|
DATA-ENTRY can be a symbol or a cons cell (SYMBOL . INITIAL-VALUE)."
|
|
(if (consp data-entry)
|
|
(car data-entry)
|
|
data-entry))
|
|
|
|
(defun tp--register-layer-data (layer-name data-vars)
|
|
"Register DATA-VARS for LAYER-NAME.
|
|
DATA-VARS is a list of variable symbols or cons cells (SYMBOL . INITIAL-VALUE).
|
|
Also adds variable watchers so changes to data vars trigger computed updates."
|
|
(when data-vars
|
|
;; Extract just the symbols for storage
|
|
(let ((var-symbols (mapcar #'tp--data-var-symbol data-vars)))
|
|
(if (assoc layer-name tp-layer-data)
|
|
(setf (cdr (assoc layer-name tp-layer-data)) var-symbols)
|
|
(push (cons layer-name var-symbols) tp-layer-data))
|
|
;; Add watchers for data variables
|
|
(dolist (var-sym var-symbols)
|
|
(let ((existing (assoc var-sym tp-reactive-deps)))
|
|
(if existing
|
|
;; Add this layer to existing dependencies
|
|
;; (with nil props since data vars don't have direct props)
|
|
(let ((layer-entry (assoc layer-name (cdr existing))))
|
|
(unless layer-entry
|
|
(push (cons layer-name nil) (cdr existing))))
|
|
;; Create new dependency entry and add watcher
|
|
(push (cons var-sym (list (cons layer-name nil))) tp-reactive-deps)
|
|
(unless (boundp var-sym) (set var-sym nil))
|
|
(add-variable-watcher var-sym #'tp--reactive-variable-watcher)))))))
|
|
|
|
(defun tp--unregister-layer-data (layer-name)
|
|
"Unregister data variables for LAYER-NAME."
|
|
(setq tp-layer-data (assq-delete-all layer-name tp-layer-data)))
|
|
|
|
(defun tp--ensure-reactive-variables (var-symbols)
|
|
"Ensure all VAR-SYMBOLS are defined as global variables.
|
|
VAR-SYMBOLS can be a list of symbols or cons cells (SYMBOL . INITIAL-VALUE).
|
|
If a variable is not bound, define it with the initial value (nil if
|
|
not specified).
|
|
If a variable has an explicit initial value (cons cell), always update
|
|
it to allow re-definition to change initial values."
|
|
(dolist (sym var-symbols)
|
|
(let* ((is-cons (and (consp sym) (not (tp--reactive-symbol-p sym))))
|
|
(var-sym (cond
|
|
(is-cons (car sym))
|
|
((tp--reactive-symbol-p sym)
|
|
(tp--reactive-var-symbol sym))
|
|
(t sym)))
|
|
(initial-val (if is-cons (cdr sym) nil)))
|
|
(if is-cons
|
|
;; For explicit initial values, always update (allows re-definition)
|
|
(set var-sym initial-val)
|
|
;; For implicit initial values, only set if not already bound
|
|
(unless (boundp var-sym)
|
|
(set var-sym initial-val))))))
|
|
|
|
;;;###autoload
|
|
(defun tp-reactive-reset ()
|
|
"Reset all reactive text property watchers and dependencies."
|
|
(interactive)
|
|
(tp--reactive-graph-reset)
|
|
;; Remove all variable watchers
|
|
(dolist (dep tp-reactive-deps)
|
|
(let ((var-sym (car dep)))
|
|
(remove-variable-watcher var-sym #'tp--reactive-variable-watcher)))
|
|
;; Clear all registries
|
|
(setq tp-reactive-deps nil)
|
|
(setq tp-layer-watchers nil)
|
|
(setq tp-reactive-observer-errors nil)
|
|
(setq tp-layer-computed nil)
|
|
(setq tp-layer-data nil)
|
|
;; Drop queued re-renders too: entries stranded by an error escaping
|
|
;; an update would otherwise survive the reset and replay against
|
|
;; freshly (re)defined layers on the next flush (ARCH-4).
|
|
(setq tp--batch-update-pending nil)
|
|
(clrhash tp--layer-buffers))
|
|
|
|
(provide 'tp-reactive)
|
|
;;; tp-reactive.el ends here
|