1099 lines
47 KiB
EmacsLisp
1099 lines
47 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.
|
|
|
|
;;; 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)
|
|
|
|
(cl-defstruct (tp--signal-commit-entry
|
|
(:constructor tp--make-signal-commit-entry))
|
|
"One transaction signal's candidate and exact committed rollback state."
|
|
signal old-committed-value old-revision candidate-value)
|
|
|
|
(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--transaction-signal-commit-journal nil)
|
|
(defvar tp--transaction-contained-failures nil)
|
|
(defvar tp--last-transaction-diagnostics 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-precommit-functions nil
|
|
"Internal TP-owned precommit hook symbols in deterministic order.")
|
|
(defconst tp--transaction-precommit-allowed-functions
|
|
'(tp--surface-precommit-transaction)
|
|
"Exact TP-owned symbols allowed in the internal precommit registry.")
|
|
(defvar tp--transaction-final-accept-function
|
|
#'tp--transaction-noop-final-accept
|
|
"Internal single final-accept function for the active transaction.")
|
|
(defvar tp--transaction-rollback-functions nil)
|
|
(defvar tp--transaction-rollback-final-functions nil)
|
|
(defvar tp--transaction-committed-functions nil)
|
|
|
|
(defconst tp--transaction-condition-trailer-tag
|
|
(make-symbol "tp--transaction-condition-trailer")
|
|
"Unforgeable tag separating primary condition data from TP metadata.")
|
|
|
|
(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)
|
|
(tp--copy-property-value
|
|
(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 (tp--copy-property-value 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--bind-precomputed-in-transaction
|
|
(owner key compute value dependencies equality lifecycle)
|
|
"Install one new initialized binding with explicit DEPENDENCIES."
|
|
(let ((table (tp--owner-binding-table owner t)))
|
|
(when (gethash key table)
|
|
(signal 'tp-reactive-error (list :precomputed-binding-exists key)))
|
|
(dolist (dependency dependencies)
|
|
(cond ((tp-signal-p dependency) (tp--validate-live-signal dependency))
|
|
((tp-binding-p dependency) (tp--validate-live-binding dependency))
|
|
(t (signal 'wrong-type-argument
|
|
(list '(or tp-signal-p tp-binding-p) dependency)))))
|
|
(let ((binding
|
|
(tp--make-binding
|
|
:id (cl-incf tp--binding-id-counter)
|
|
:owner owner :key (tp--copy-property-value key) :compute compute
|
|
:equality equality :last-value value :initialized-p t
|
|
:dependencies (copy-sequence dependencies)
|
|
:subscribers (make-hash-table :test #'eq)
|
|
:dirty nil :state 'clean :revision 1 :lifecycle lifecycle)))
|
|
(tp--register-binding binding)
|
|
(push binding tp--transaction-created-bindings)
|
|
(dolist (dependency dependencies)
|
|
(tp--subscription-add dependency binding))
|
|
(when tp--binding-touch-function
|
|
(funcall tp--binding-touch-function binding))
|
|
binding)))
|
|
|
|
(cl-defun tp-bind-precomputed
|
|
(owner key compute value dependencies
|
|
&key (equality #'equal) (lifecycle 'delete))
|
|
"Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
|
|
COMPUTE remains the authoritative recomputation function after any dependency
|
|
changes. This entry avoids evaluating COMPUTE merely to rediscover a value
|
|
and graph edges already produced by a compiler or pure projection pass."
|
|
(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)
|
|
(unless (proper-list-p dependencies)
|
|
(signal 'wrong-type-argument (list 'proper-list-p dependencies)))
|
|
(if tp--transaction-active
|
|
(tp--bind-precomputed-in-transaction
|
|
owner key compute value dependencies equality lifecycle)
|
|
(tp--call-with-transaction
|
|
(lambda ()
|
|
(tp--bind-precomputed-in-transaction
|
|
owner key compute value dependencies 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 (tp--copy-property-value key) tp--transaction-participant-keys)
|
|
(push (tp--make-transaction-participant
|
|
:key (tp--copy-property-value 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 quit)
|
|
(push (list 'participants
|
|
(tp--transaction-participant-key participant)
|
|
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--transaction-noop-final-accept ()
|
|
"Accept a pure reactive transaction with no external publication work."
|
|
nil)
|
|
|
|
(defun tp--transaction-precommit-function-p (function)
|
|
"Return non-nil when FUNCTION is a declared TP-internal hook symbol."
|
|
(and (symbolp function)
|
|
(memq function tp--transaction-precommit-allowed-functions)
|
|
(fboundp function)))
|
|
|
|
(defun tp--transaction-register-precommit-function (function)
|
|
"Register declared TP-internal precommit FUNCTION once."
|
|
(unless (tp--transaction-precommit-function-p function)
|
|
(signal 'tp-reactive-error
|
|
(list :invalid-precommit-function function)))
|
|
(unless (memq function tp--transaction-precommit-functions)
|
|
(setq tp--transaction-precommit-functions
|
|
(append tp--transaction-precommit-functions (list function))))
|
|
function)
|
|
|
|
(defun tp--transaction-install-final-accept (function)
|
|
"Install the active transaction's single final-accept FUNCTION."
|
|
(unless tp--transaction-active
|
|
(signal 'tp-reactive-error (list :final-accept-outside-transaction)))
|
|
(unless (functionp function)
|
|
(signal 'wrong-type-argument (list 'functionp function)))
|
|
(unless (eq tp--transaction-final-accept-function
|
|
#'tp--transaction-noop-final-accept)
|
|
(signal 'tp-reactive-error
|
|
(list :duplicate-final-accept-function
|
|
tp--transaction-final-accept-function function)))
|
|
(setq tp--transaction-final-accept-function function))
|
|
|
|
(defun tp--run-contained-transaction-functions (phase functions)
|
|
"Run postaccept PHASE FUNCTIONS and record contained failures."
|
|
(dolist (function (tp--transaction-hook-functions functions))
|
|
(let ((inhibit-quit t)
|
|
(quit-flag nil))
|
|
(condition-case failure
|
|
(funcall function)
|
|
((error quit)
|
|
(push (list phase function failure)
|
|
tp--transaction-contained-failures))))))
|
|
|
|
(defun tp--run-transaction-precommit-functions ()
|
|
"Run the internal declared precommit registry in deterministic order."
|
|
(dolist (function tp--transaction-precommit-functions)
|
|
(unless (tp--transaction-precommit-function-p function)
|
|
(signal 'tp-reactive-error
|
|
(list :invalid-precommit-function function)))
|
|
(funcall function)))
|
|
|
|
(defun tp--prepare-signal-commit-journal ()
|
|
"Capture every touched signal before any committed field is mutated."
|
|
(setq tp--transaction-signal-commit-journal
|
|
(mapcar
|
|
(lambda (signal)
|
|
(tp--make-signal-commit-entry
|
|
:signal signal
|
|
:old-committed-value (tp-signal-committed-value signal)
|
|
:old-revision (tp-signal-revision signal)
|
|
:candidate-value
|
|
(gethash signal tp--transaction-signal-values)))
|
|
(nreverse (copy-sequence tp--transaction-signals)))))
|
|
|
|
(defun tp--commit-signal-entry (entry)
|
|
"Commit signal journal ENTRY exactly once."
|
|
(let ((signal (tp--signal-commit-entry-signal entry)))
|
|
(setf (tp-signal-committed-value signal)
|
|
(tp--signal-commit-entry-candidate-value entry)
|
|
(tp-signal-revision signal)
|
|
(1+ (tp--signal-commit-entry-old-revision entry)))))
|
|
|
|
(defun tp--restore-signal-entry (entry)
|
|
"Restore signal journal ENTRY's exact committed state."
|
|
(let ((signal (tp--signal-commit-entry-signal entry)))
|
|
(setf (tp-signal-committed-value signal)
|
|
(tp--signal-commit-entry-old-committed-value entry)
|
|
(tp-signal-revision signal)
|
|
(tp--signal-commit-entry-old-revision entry))))
|
|
|
|
(defun tp--commit-signal-values ()
|
|
"Journal and commit candidate signals in stable first-touch order."
|
|
(tp--prepare-signal-commit-journal)
|
|
(dolist (entry tp--transaction-signal-commit-journal)
|
|
(tp--commit-signal-entry entry)))
|
|
|
|
(defun tp--restore-transaction-counters (snapshot)
|
|
"Restore reactive counters from SNAPSHOT."
|
|
(setq tp--reactive-counters snapshot))
|
|
|
|
(defun tp--transaction-hook-functions (value)
|
|
"Return hook VALUE as one ordered function list."
|
|
(cond
|
|
((null value) nil)
|
|
((functionp value) (list value))
|
|
(t value)))
|
|
|
|
(defun tp--rollback-hook-phase (phase functions)
|
|
"Run rollback PHASE FUNCTIONS and return ordered failures."
|
|
(let (failures)
|
|
(dolist (function (tp--transaction-hook-functions functions))
|
|
(condition-case failure
|
|
(funcall function)
|
|
((error quit)
|
|
(push (list phase function failure) failures))))
|
|
(nreverse failures)))
|
|
|
|
(defun tp--rollback-signal-journal ()
|
|
"Restore every signal journal entry and return ordered failures."
|
|
(let (failures)
|
|
(dolist (entry tp--transaction-signal-commit-journal)
|
|
(condition-case failure
|
|
(tp--restore-signal-entry entry)
|
|
((error quit)
|
|
(push (list 'signal-journal
|
|
(tp-signal-id
|
|
(tp--signal-commit-entry-signal entry))
|
|
failure)
|
|
failures))))
|
|
(nreverse failures)))
|
|
|
|
(defun tp--rollback-transaction-state (counter-snapshot)
|
|
"Restore COUNTER-SNAPSHOT through every rollback phase.
|
|
Return contained failures in phase order."
|
|
(let ((failures (tp--rollback-transaction-participants)))
|
|
(setq failures
|
|
(append
|
|
failures
|
|
(tp--rollback-hook-phase
|
|
'rollback-hooks tp--transaction-rollback-functions)
|
|
(tp--rollback-signal-journal)))
|
|
(condition-case failure
|
|
(tp--rollback-bindings)
|
|
((error quit)
|
|
(setq failures
|
|
(append failures
|
|
(list (list 'bindings 'binding-graph failure))))))
|
|
(condition-case failure
|
|
(tp--restore-transaction-counters counter-snapshot)
|
|
((error quit)
|
|
(setq failures
|
|
(append failures
|
|
(list (list 'counters 'reactive-counters failure))))))
|
|
(append
|
|
failures
|
|
(tp--rollback-hook-phase
|
|
'rollback-final tp--transaction-rollback-final-functions))))
|
|
|
|
(defun tp--resignal-transaction-primary (primary-condition failures)
|
|
"Re-signal PRIMARY-CONDITION with ordered rollback FAILURES attached."
|
|
(signal (car primary-condition)
|
|
(if failures
|
|
(append (cdr primary-condition)
|
|
(list tp--transaction-condition-trailer-tag
|
|
(list :rollback-failures failures)))
|
|
(cdr primary-condition))))
|
|
|
|
(defun tp--transaction-condition-trailer (condition property)
|
|
"Return PROPERTY from the exact transaction trailer of CONDITION.
|
|
Transaction rollback metadata is appended after, and never merged into,
|
|
the primary condition data."
|
|
(let ((trailer (last condition 2)))
|
|
(and (eq (car trailer) tp--transaction-condition-trailer-tag)
|
|
(plist-get (cadr trailer) property))))
|
|
|
|
(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
|
|
(tp--transaction-contained-failures nil))
|
|
(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)
|
|
(tp--transaction-signal-commit-journal nil)
|
|
(tp--transaction-final-accept-function
|
|
#'tp--transaction-noop-final-accept)
|
|
(counter-snapshot (copy-sequence tp--reactive-counters))
|
|
(tp--transaction-counter-start nil)
|
|
success transaction-result primary-condition
|
|
rollback-failures pending-quit)
|
|
(setq tp--transaction-counter-start counter-snapshot)
|
|
(unwind-protect
|
|
(condition-case condition
|
|
(progn
|
|
(setq transaction-result (funcall function))
|
|
(tp--flush-dirty-bindings)
|
|
(run-hooks 'tp--transaction-publish-functions)
|
|
(tp--publish-transaction-participants)
|
|
(tp--run-transaction-precommit-functions)
|
|
(tp--commit-signal-values)
|
|
(condition-case deferred-quit
|
|
(progn
|
|
(let ((inhibit-quit t)
|
|
(quit-flag nil))
|
|
(unwind-protect
|
|
(progn
|
|
(unless
|
|
(functionp
|
|
tp--transaction-final-accept-function)
|
|
(signal
|
|
'tp-reactive-error
|
|
(list
|
|
:invalid-final-accept-function
|
|
tp--transaction-final-accept-function)))
|
|
(funcall
|
|
tp--transaction-final-accept-function)
|
|
(setq success t)
|
|
(when quit-flag
|
|
(setq pending-quit t
|
|
quit-flag nil))
|
|
(tp--run-contained-transaction-functions
|
|
'committed
|
|
tp--transaction-committed-functions)
|
|
(setq after-commit
|
|
(nreverse
|
|
tp--transaction-after-commit-callbacks))
|
|
(when pending-quit
|
|
(push
|
|
(list 'final-accept
|
|
tp--transaction-final-accept-function
|
|
'(quit))
|
|
tp--transaction-contained-failures)))
|
|
(setq quit-flag nil)))
|
|
nil)
|
|
(quit
|
|
(if success
|
|
(push
|
|
(list 'final-accept
|
|
tp--transaction-final-accept-function
|
|
deferred-quit)
|
|
tp--transaction-contained-failures)
|
|
(signal (car deferred-quit)
|
|
(cdr deferred-quit))))))
|
|
((error quit)
|
|
(setq primary-condition condition)))
|
|
(unless success
|
|
(let ((inhibit-quit t)
|
|
(quit-flag nil))
|
|
(unwind-protect
|
|
(setq rollback-failures
|
|
(tp--rollback-transaction-state
|
|
counter-snapshot))
|
|
(setq quit-flag nil)))))
|
|
(when primary-condition
|
|
(tp--resignal-transaction-primary
|
|
primary-condition rollback-failures))
|
|
transaction-result))
|
|
(tp--run-contained-transaction-functions 'after-commit after-commit)
|
|
(setq tp--last-transaction-diagnostics
|
|
(nreverse tp--transaction-contained-failures))
|
|
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))
|
|
|
|
;;;###autoload
|
|
(defun tp-reactive-reset ()
|
|
"Reset TP's signal, binding, adapter, and scheduler graph."
|
|
(interactive)
|
|
(tp--reactive-graph-reset))
|
|
|
|
(provide 'tp-reactive)
|
|
;;; tp-reactive.el ends here
|