799 lines
35 KiB
EmacsLisp
799 lines
35 KiB
EmacsLisp
;;; tp-binding-tests.el --- Tests for TP binding graph -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
|
|
;;; Commentary:
|
|
|
|
;; Contract tests for TP 1.0 signals, bindings, and transactions.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp-reactive)
|
|
|
|
(defvar tp-binding-test-variable nil
|
|
"Variable used by scoped signal adapter tests.")
|
|
|
|
(define-error 'tp-binding-test-primary "TP binding test primary failure")
|
|
|
|
(defvar tp-binding-test-transaction-trace nil
|
|
"Dynamic transaction phase trace used by rollback tests.")
|
|
|
|
(defvar tp-binding-test-precommit-condition nil
|
|
"Condition signaled by the test precommit hook, or nil.")
|
|
|
|
(defvar tp-binding-test-final-accept-function nil
|
|
"Test final-accept function installed by the test precommit hook.")
|
|
|
|
(defun tp--binding-test-precommit-inject ()
|
|
"Record precommit and signal `tp-binding-test-precommit-condition'."
|
|
(push 'precommit tp-binding-test-transaction-trace)
|
|
(when tp-binding-test-final-accept-function
|
|
(tp--transaction-install-final-accept
|
|
tp-binding-test-final-accept-function))
|
|
(when tp-binding-test-precommit-condition
|
|
(signal (car tp-binding-test-precommit-condition)
|
|
(cdr tp-binding-test-precommit-condition))))
|
|
|
|
(defun tp--binding-test-foreign-precommit ()
|
|
"Represent an undeclared private-looking foreign precommit function."
|
|
nil)
|
|
|
|
(defun tp-binding-test--rollback-hook-fail ()
|
|
"Record rollback hook failure and signal it."
|
|
(push 'rollback-hook-fail tp-binding-test-transaction-trace)
|
|
(error "Rollback hook failure"))
|
|
|
|
(defun tp-binding-test--rollback-hook-after ()
|
|
"Record the rollback hook following a failed hook."
|
|
(push 'rollback-hook-after tp-binding-test-transaction-trace))
|
|
|
|
(defun tp-binding-test--rollback-final-fail ()
|
|
"Record rollback-final failure and signal it."
|
|
(push 'rollback-final-fail tp-binding-test-transaction-trace)
|
|
(error "Rollback final failure"))
|
|
|
|
(defun tp-binding-test--rollback-final-after ()
|
|
"Record the rollback-final hook following a failed hook."
|
|
(push 'rollback-final-after tp-binding-test-transaction-trace))
|
|
|
|
(defun tp-binding-test--capture-condition (function)
|
|
"Call FUNCTION and return its signaled error or quit condition."
|
|
(condition-case condition
|
|
(progn (funcall function) nil)
|
|
(error condition)
|
|
(quit condition)))
|
|
|
|
(defmacro tp-binding-test--isolated (&rest body)
|
|
"Run BODY with an isolated reactive runtime."
|
|
(declare (indent 0) (debug t))
|
|
`(progn
|
|
(tp-reactive-reset)
|
|
(unwind-protect (progn ,@body)
|
|
(tp-reactive-reset))))
|
|
|
|
(ert-deftest tp-binding-test-signal-invalidates-only-direct-subscribers ()
|
|
"A sparse signal write never visits unrelated bindings."
|
|
(tp-binding-test--isolated
|
|
(let ((target (tp-signal-create 0))
|
|
(unrelated (tp-signal-create 0))
|
|
(target-calls 0)
|
|
(unrelated-calls 0))
|
|
(tp-with-transaction
|
|
(tp-bind 'target-owner '(test . value)
|
|
(lambda ()
|
|
(cl-incf target-calls)
|
|
(tp-signal-read target)))
|
|
(dotimes (index 9999)
|
|
(tp-bind (list 'unrelated-owner index) '(test . value)
|
|
(lambda ()
|
|
(cl-incf unrelated-calls)
|
|
(tp-signal-read unrelated)))))
|
|
(should (= target-calls 1))
|
|
(should (= unrelated-calls 9999))
|
|
(tp-reactive-reset-counters)
|
|
(cl-letf (((symbol-function 'buffer-list)
|
|
(lambda (&rest _) (error "Legacy scan")))
|
|
((symbol-function 'text-property-search-forward)
|
|
(lambda (&rest _) (error "Legacy scan")))
|
|
((symbol-function 'tp-reactive--buffer-layer-names)
|
|
(lambda (&rest _) (error "Legacy scan")))
|
|
((symbol-function 'tp-reactive-layer-buffers)
|
|
(lambda (&rest _) (error "Legacy scan"))))
|
|
(tp-signal-set target 1))
|
|
(should (= target-calls 2))
|
|
(should (= unrelated-calls 9999))
|
|
(should (equal (tp-reactive-counters)
|
|
'(:invalidated 1 :recomputed 1 :skipped 0
|
|
:subscription-added 0 :subscription-removed 0))))))
|
|
|
|
(ert-deftest tp-binding-test-conditional-dependencies-rewire ()
|
|
"A binding unsubscribes from the branch it no longer reads."
|
|
(tp-binding-test--isolated
|
|
(let ((enabled (tp-signal-create t))
|
|
(active (tp-signal-create 'active))
|
|
(disabled (tp-signal-create 'disabled))
|
|
(calls 0))
|
|
(tp-bind 'owner '(test . branch)
|
|
(lambda ()
|
|
(cl-incf calls)
|
|
(if (tp-signal-read enabled)
|
|
(tp-signal-read active)
|
|
(tp-signal-read disabled))))
|
|
(tp-signal-set enabled nil)
|
|
(should (= calls 2))
|
|
(tp-signal-set active 'ignored)
|
|
(should (= calls 2))
|
|
(tp-signal-set disabled 'changed)
|
|
(should (= calls 3)))))
|
|
|
|
(ert-deftest tp-binding-test-equal-signal-write-is-noop ()
|
|
"Setting an equal signal value does not dirty its binding."
|
|
(tp-binding-test--isolated
|
|
(let ((source (tp-signal-create '(1 2) :equality #'equal))
|
|
(calls 0))
|
|
(tp-bind 'owner '(test . value)
|
|
(lambda ()
|
|
(cl-incf calls)
|
|
(tp-signal-read source)))
|
|
(tp-reactive-reset-counters)
|
|
(tp-signal-set source (list 1 2))
|
|
(should (= calls 1))
|
|
(should (equal (tp-reactive-counters)
|
|
'(:invalidated 0 :recomputed 0 :skipped 0
|
|
:subscription-added 0 :subscription-removed 0))))))
|
|
|
|
(ert-deftest tp-binding-test-transaction-deduplicates-writes ()
|
|
"Repeated writes in one transaction recompute each binding once."
|
|
(tp-binding-test--isolated
|
|
(let ((source (tp-signal-create 0))
|
|
(calls 0))
|
|
(tp-bind 'owner '(test . value)
|
|
(lambda ()
|
|
(cl-incf calls)
|
|
(tp-signal-read source)))
|
|
(tp-reactive-reset-counters)
|
|
(tp-with-transaction
|
|
(dotimes (value 100)
|
|
(tp-signal-set source (1+ value))))
|
|
(should (= (tp-signal-peek source) 100))
|
|
(should (= calls 2))
|
|
(should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
|
|
|
|
(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
|
|
"Touched signals commit once in first-touch order, including net reverts."
|
|
(tp-binding-test--isolated
|
|
(let* ((first (tp-signal-create 0))
|
|
(second (tp-signal-create 0))
|
|
(third (tp-signal-create 0))
|
|
(original (symbol-function 'tp--commit-signal-entry))
|
|
commit-order final-accept-order (final-accept-count 0))
|
|
(cl-letf (((symbol-function 'tp--commit-signal-entry)
|
|
(lambda (entry)
|
|
(push (tp-signal-id
|
|
(tp--signal-commit-entry-signal entry))
|
|
commit-order)
|
|
(funcall original entry)))
|
|
((symbol-function 'tp--transaction-noop-final-accept)
|
|
(lambda ()
|
|
(cl-incf final-accept-count)
|
|
(setq final-accept-order
|
|
(mapcar
|
|
(lambda (entry)
|
|
(tp-signal-id
|
|
(tp--signal-commit-entry-signal entry)))
|
|
tp--transaction-signal-commit-journal)))))
|
|
(tp-with-transaction
|
|
(tp-signal-set second 1)
|
|
(tp-with-transaction
|
|
(tp-signal-set first 1)
|
|
(tp-signal-set second 0))
|
|
(tp-signal-set third 3)))
|
|
(setq commit-order (nreverse commit-order))
|
|
(should (equal commit-order
|
|
(mapcar #'tp-signal-id (list second first third))))
|
|
(should (equal final-accept-order commit-order))
|
|
(should (= final-accept-count 1))
|
|
(should (= (tp-signal-peek first) 1))
|
|
(should (= (tp-signal-peek second) 0))
|
|
(should (= (tp-signal-peek third) 3))
|
|
(dolist (signal (list first second third))
|
|
(should (= (tp-signal-revision signal) 1))))))
|
|
|
|
(ert-deftest tp-binding-test-signal-commit-journal-rolls-back-every-write ()
|
|
"Every signal-write injection restores values, revisions, and bindings."
|
|
(tp-binding-test--isolated
|
|
(dolist (fail-after '(0 1 2 3))
|
|
(let* ((first (tp-signal-create 1))
|
|
(second (tp-signal-create 2))
|
|
(third (tp-signal-create 3))
|
|
(binding
|
|
(tp-bind (list 'owner fail-after) '(test . sum)
|
|
(lambda ()
|
|
(+ (tp-signal-read first)
|
|
(tp-signal-read second)
|
|
(tp-signal-read third)))))
|
|
(binding-revision (tp-binding-revision binding))
|
|
(original (symbol-function 'tp--commit-signal-entry))
|
|
(writes 0))
|
|
(cl-letf (((symbol-function 'tp--commit-signal-entry)
|
|
(lambda (entry)
|
|
(when (and (zerop fail-after) (zerop writes))
|
|
(error "Before first signal write"))
|
|
(funcall original entry)
|
|
(cl-incf writes)
|
|
(when (= writes fail-after)
|
|
(error "After signal write %d" writes)))))
|
|
(should-error
|
|
(tp-with-transaction
|
|
(tp-signal-set first 10)
|
|
(tp-signal-set second 20)
|
|
(tp-signal-set third 30))))
|
|
(should (equal (mapcar #'tp-signal-peek (list first second third))
|
|
'(1 2 3)))
|
|
(should (equal (mapcar #'tp-signal-revision
|
|
(list first second third))
|
|
'(0 0 0)))
|
|
(should (= (tp-binding-read binding) 6))
|
|
(should (= (tp-binding-revision binding) binding-revision))
|
|
(should (= (tp-binding-dependency-count binding) 3))
|
|
(dolist (signal (list first second third))
|
|
(should (= (tp-signal-subscriber-count signal) 1)))
|
|
(tp-with-transaction
|
|
(tp-signal-set first 10)
|
|
(tp-signal-set second 20)
|
|
(tp-signal-set third 30))
|
|
(should (equal (mapcar #'tp-signal-peek (list first second third))
|
|
'(10 20 30)))
|
|
(should (equal (mapcar #'tp-signal-revision
|
|
(list first second third))
|
|
'(1 1 1)))
|
|
(should (= (tp-binding-read binding) 60))))))
|
|
|
|
(ert-deftest tp-binding-test-precommit-and-final-accept-failures-roll-back ()
|
|
"Precommit and final-accept error or quit restores pure reactive state."
|
|
(tp-binding-test--isolated
|
|
(dolist (phase '(precommit final-accept))
|
|
(dolist (condition '((error "Injected error") (quit)))
|
|
(let* ((signal (tp-signal-create 1))
|
|
observed-final
|
|
(tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp-binding-test-precommit-condition
|
|
(and (eq phase 'precommit) condition))
|
|
(tp-binding-test-final-accept-function
|
|
(and (eq phase 'final-accept)
|
|
(lambda ()
|
|
(setq observed-final
|
|
(list (tp-signal-committed-value signal)
|
|
(tp-signal-revision signal)))
|
|
(signal (car condition) (cdr condition))))))
|
|
(let ((failure
|
|
(tp-binding-test--capture-condition
|
|
(lambda ()
|
|
(tp-with-transaction (tp-signal-set signal 2))))))
|
|
(should (eq (car failure) (car condition))))
|
|
(when (eq phase 'final-accept)
|
|
(should (equal observed-final '(2 1))))
|
|
(should (= (tp-signal-peek signal) 1))
|
|
(should (= (tp-signal-revision signal) 0))
|
|
(setq tp--transaction-precommit-functions nil
|
|
tp-binding-test-precommit-condition nil
|
|
tp-binding-test-final-accept-function nil)
|
|
(tp-signal-set signal 2)
|
|
(should (= (tp-signal-peek signal) 2))
|
|
(should (= (tp-signal-revision signal) 1)))))))
|
|
|
|
(ert-deftest tp-binding-test-final-accept-pending-quit-is-contained ()
|
|
"Clear final-accept pending quit before committed and after-commit actions."
|
|
(tp-binding-test--isolated
|
|
(let ((signal (tp-signal-create 1)) after-ran
|
|
(tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp-binding-test-final-accept-function
|
|
(lambda () (setq quit-flag t))))
|
|
(tp-with-transaction
|
|
(tp-signal-set signal 2)
|
|
(tp--enqueue-after-commit (lambda () (setq after-ran t))))
|
|
(should (= 2 (tp-signal-peek signal)))
|
|
(should after-ran)
|
|
(should (eq 'final-accept
|
|
(caar tp--last-transaction-diagnostics))))))
|
|
|
|
(ert-deftest tp-binding-test-precommit-registry-rejects-foreign-functions ()
|
|
"Only declared TP-internal symbols may enter the precommit registry."
|
|
(tp-binding-test--isolated
|
|
(let ((tp--transaction-precommit-functions nil)
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject)))
|
|
(tp--transaction-register-precommit-function
|
|
'tp--binding-test-precommit-inject)
|
|
(should (equal tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject)))
|
|
(should-error
|
|
(tp--transaction-register-precommit-function
|
|
'tp--binding-test-foreign-precommit)
|
|
:type 'tp-reactive-error)
|
|
(dolist (foreign
|
|
(list 'ignore 'tp--binding-test-foreign-precommit
|
|
(lambda () nil)))
|
|
(let ((signal (tp-signal-create 1))
|
|
(tp--transaction-precommit-functions (list foreign)))
|
|
(should-error
|
|
(tp-with-transaction (tp-signal-set signal 2))
|
|
:type 'tp-reactive-error)
|
|
(should (= (tp-signal-peek signal) 1))
|
|
(should (= (tp-signal-revision signal) 0)))))))
|
|
|
|
(ert-deftest tp-binding-test-production-precommit-registry-is-exact ()
|
|
"The package exposes exactly its one statically declared precommit owner."
|
|
(should (equal tp--transaction-precommit-allowed-functions
|
|
'(tp--surface-precommit-transaction)))
|
|
(should (equal tp--transaction-precommit-functions
|
|
'(tp--surface-precommit-transaction))))
|
|
|
|
(ert-deftest tp-binding-test-condition-trailer-cannot-collide-with-primary-data ()
|
|
"User condition data ending like rollback metadata is not a TP trailer."
|
|
(let ((condition '(error "Primary" :rollback-failures user-value)))
|
|
(should-not
|
|
(tp--transaction-condition-trailer condition :rollback-failures))))
|
|
|
|
(ert-deftest tp-binding-test-rollback-preserves-primary-and-runs-all-phases ()
|
|
"Rollback failures attach in order without replacing the primary condition."
|
|
(tp-binding-test--isolated
|
|
(let* ((signal (tp-signal-create 1))
|
|
(binding (tp-bind 'owner '(test . rollback)
|
|
(lambda () (tp-signal-read signal))))
|
|
(tp-binding-test-transaction-trace nil)
|
|
(tp-binding-test-precommit-condition nil)
|
|
(tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp-binding-test-final-accept-function
|
|
(lambda ()
|
|
(signal 'tp-binding-test-primary
|
|
'(:payload 7 :rollback-failures user-value))))
|
|
(tp--transaction-rollback-functions
|
|
'(tp-binding-test--rollback-hook-fail
|
|
tp-binding-test--rollback-hook-after))
|
|
(tp--transaction-rollback-final-functions
|
|
'(tp-binding-test--rollback-final-fail
|
|
tp-binding-test--rollback-final-after))
|
|
(restore-signal (symbol-function 'tp--restore-signal-entry))
|
|
(rollback-bindings (symbol-function 'tp--rollback-bindings))
|
|
(restore-counters
|
|
(symbol-function 'tp--restore-transaction-counters))
|
|
signal-restore-failed
|
|
failure)
|
|
(cl-letf (((symbol-function 'tp--restore-signal-entry)
|
|
(lambda (entry)
|
|
(funcall restore-signal entry)
|
|
(push 'signal-restored tp-binding-test-transaction-trace)
|
|
(unless signal-restore-failed
|
|
(setq signal-restore-failed t)
|
|
(error "Signal restore failure"))))
|
|
((symbol-function 'tp--rollback-bindings)
|
|
(lambda ()
|
|
(funcall rollback-bindings)
|
|
(push 'bindings-restored
|
|
tp-binding-test-transaction-trace)))
|
|
((symbol-function 'tp--restore-transaction-counters)
|
|
(lambda (snapshot)
|
|
(funcall restore-counters snapshot)
|
|
(push 'counters-restored
|
|
tp-binding-test-transaction-trace))))
|
|
(setq failure
|
|
(condition-case condition
|
|
(tp-with-transaction
|
|
(tp-transaction-participate
|
|
'first
|
|
(lambda ()
|
|
(push 'publish-first
|
|
tp-binding-test-transaction-trace))
|
|
(lambda ()
|
|
(push 'rollback-first
|
|
tp-binding-test-transaction-trace)))
|
|
(tp-transaction-participate
|
|
'second
|
|
(lambda ()
|
|
(push 'publish-second
|
|
tp-binding-test-transaction-trace))
|
|
(lambda ()
|
|
(push 'rollback-second
|
|
tp-binding-test-transaction-trace)))
|
|
(tp-signal-set signal 2))
|
|
(tp-binding-test-primary condition))))
|
|
(should (eq (car failure) 'tp-binding-test-primary))
|
|
(should (= (plist-get (cdr failure) :payload) 7))
|
|
(should (equal (butlast failure 2)
|
|
'(tp-binding-test-primary
|
|
:payload 7 :rollback-failures user-value)))
|
|
(let ((rollback-failures
|
|
(tp--transaction-condition-trailer
|
|
failure :rollback-failures)))
|
|
(should (equal (mapcar #'car rollback-failures)
|
|
'(rollback-hooks signal-journal rollback-final))))
|
|
(should
|
|
(equal (nreverse tp-binding-test-transaction-trace)
|
|
'(publish-first publish-second precommit
|
|
rollback-second rollback-first
|
|
rollback-hook-fail rollback-hook-after
|
|
signal-restored bindings-restored counters-restored
|
|
rollback-final-fail rollback-final-after)))
|
|
(should (= (tp-signal-peek signal) 1))
|
|
(should (= (tp-signal-revision signal) 0))
|
|
(should (= (tp-binding-read binding) 1)))))
|
|
|
|
(ert-deftest tp-binding-test-rollback-preserves-quit-primary ()
|
|
"A quit remains primary when rollback hooks fail and later hooks still run."
|
|
(tp-binding-test--isolated
|
|
(let* ((signal (tp-signal-create 1))
|
|
(tp-binding-test-transaction-trace nil)
|
|
(tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp-binding-test-final-accept-function
|
|
(lambda () (signal 'quit '(:payload 9))))
|
|
(tp--transaction-rollback-functions
|
|
'(tp-binding-test--rollback-hook-fail
|
|
tp-binding-test--rollback-hook-after))
|
|
(failure
|
|
(tp-binding-test--capture-condition
|
|
(lambda ()
|
|
(tp-with-transaction (tp-signal-set signal 2))))))
|
|
(should (eq (car failure) 'quit))
|
|
(should (= (plist-get (cdr failure) :payload) 9))
|
|
(should
|
|
(equal (mapcar #'car
|
|
(tp--transaction-condition-trailer
|
|
failure :rollback-failures))
|
|
'(rollback-hooks)))
|
|
(should (equal (nreverse tp-binding-test-transaction-trace)
|
|
'(precommit rollback-hook-fail rollback-hook-after)))
|
|
(should (= (tp-signal-peek signal) 1))
|
|
(should (= (tp-signal-revision signal) 0)))))
|
|
|
|
(ert-deftest tp-binding-test-final-accept-throw-rolls-back-nonlocally ()
|
|
"A final-accept throw preserves its tag/value after complete rollback."
|
|
(tp-binding-test--isolated
|
|
(let* ((signal (tp-signal-create 1))
|
|
(binding (tp-bind 'owner '(test . throw)
|
|
(lambda () (tp-signal-read signal))))
|
|
(binding-revision (tp-binding-revision binding))
|
|
(tp-binding-test-transaction-trace nil)
|
|
(tp--transaction-precommit-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp--transaction-precommit-allowed-functions
|
|
'(tp--binding-test-precommit-inject))
|
|
(tp-binding-test-final-accept-function
|
|
(lambda () (throw 'tp-binding-test-tag 'thrown-value)))
|
|
(tp--transaction-rollback-functions
|
|
'(tp-binding-test--rollback-hook-fail
|
|
tp-binding-test--rollback-hook-after))
|
|
(result
|
|
(catch 'tp-binding-test-tag
|
|
(tp-with-transaction (tp-signal-set signal 2))
|
|
'not-thrown)))
|
|
(should (eq result 'thrown-value))
|
|
(should (equal (nreverse tp-binding-test-transaction-trace)
|
|
'(precommit rollback-hook-fail rollback-hook-after)))
|
|
(should (= (tp-signal-peek signal) 1))
|
|
(should (= (tp-signal-revision signal) 0))
|
|
(should (= (tp-binding-read binding) 1))
|
|
(should (= (tp-binding-revision binding) binding-revision))
|
|
(setq tp-binding-test-final-accept-function nil
|
|
tp--transaction-precommit-functions nil
|
|
tp--transaction-rollback-functions nil)
|
|
(tp-signal-set signal 2)
|
|
(should (= (tp-signal-peek signal) 2))
|
|
(should (= (tp-signal-revision signal) 1)))))
|
|
|
|
(ert-deftest tp-binding-test-nested-write-queues-a-second-pass ()
|
|
"A compute write queues stabilization instead of recursing."
|
|
(tp-binding-test--isolated
|
|
(let ((source (tp-signal-create 0))
|
|
(calls 0))
|
|
(let ((binding
|
|
(tp-bind 'owner '(test . stabilizing)
|
|
(lambda ()
|
|
(cl-incf calls)
|
|
(let ((value (tp-signal-read source)))
|
|
(when (zerop value)
|
|
(tp-signal-set source 1))
|
|
value)))))
|
|
(should (= (tp-binding-read binding) 1))
|
|
(should (= (tp-signal-peek source) 1))
|
|
(should (= calls 2))))))
|
|
|
|
(ert-deftest tp-binding-test-chain-stops-at-equal-computed-value ()
|
|
"An equal intermediate value prevents downstream recomputation."
|
|
(tp-binding-test--isolated
|
|
(let* ((source (tp-signal-create 10))
|
|
(middle-calls 0)
|
|
(leaf-calls 0)
|
|
(middle
|
|
(tp-bind 'middle-owner '(test . quotient)
|
|
(lambda ()
|
|
(cl-incf middle-calls)
|
|
(/ (tp-signal-read source) 10))))
|
|
(_leaf
|
|
(tp-bind 'leaf-owner '(test . display)
|
|
(lambda ()
|
|
(cl-incf leaf-calls)
|
|
(format "%s" (tp-binding-read middle))))))
|
|
(tp-signal-set source 11)
|
|
(should (= middle-calls 2))
|
|
(should (= leaf-calls 1))
|
|
(tp-signal-set source 20)
|
|
(should (= middle-calls 3))
|
|
(should (= leaf-calls 2)))))
|
|
|
|
(ert-deftest tp-binding-test-owner-disposal-cleans-graph-edges ()
|
|
"Disposing an owner removes all incoming and outgoing subscriptions."
|
|
(tp-binding-test--isolated
|
|
(let* ((source (tp-signal-create 1))
|
|
(owner (list 'owner))
|
|
(base (tp-bind owner '(test . base)
|
|
(lambda () (tp-signal-read source))))
|
|
(derived (tp-bind owner '(test . derived)
|
|
(lambda () (1+ (tp-binding-read base))))))
|
|
(should (= (tp-signal-subscriber-count source) 1))
|
|
(should (= (tp-binding-subscriber-count base) 1))
|
|
(should (= (tp-binding-dependency-count derived) 1))
|
|
(tp-binding-dispose-owner owner)
|
|
(should (= (tp-signal-subscriber-count source) 0))
|
|
(should (= (tp-binding-subscriber-count base) 0))
|
|
(should-not (tp-binding-live-p base))
|
|
(should-not (tp-binding-live-p derived)))))
|
|
|
|
(ert-deftest tp-binding-test-failed-compute-rolls-back-values-and-dependencies ()
|
|
"A failed transaction restores signal, binding, and dependency state."
|
|
(tp-binding-test--isolated
|
|
(let* ((switch (tp-signal-create t))
|
|
(left (tp-signal-create 10))
|
|
(right (tp-signal-create 20))
|
|
(binding
|
|
(tp-bind 'owner '(test . branch)
|
|
(lambda ()
|
|
(if (tp-signal-read switch)
|
|
(tp-signal-read left)
|
|
(progn
|
|
(tp-signal-read right)
|
|
(error "Broken branch")))))))
|
|
(let ((counters-before (tp-reactive-counters)))
|
|
(should-error (tp-signal-set switch nil) :type 'error)
|
|
(should (equal (tp-reactive-counters) counters-before)))
|
|
(should (tp-signal-peek switch))
|
|
(should (= (tp-binding-read binding) 10))
|
|
(should (= (tp-signal-subscriber-count left) 1))
|
|
(should (= (tp-signal-subscriber-count right) 0))
|
|
(tp-signal-set left 11)
|
|
(should (= (tp-binding-read binding) 11)))))
|
|
|
|
(ert-deftest tp-binding-test-failed-new-binding-is-unregistered ()
|
|
"A failed initial compute invalidates and unregisters the new binding."
|
|
(tp-binding-test--isolated
|
|
(let (failed)
|
|
(should-error
|
|
(tp-bind 'owner '(test . failing)
|
|
(lambda ()
|
|
(setq failed tp--current-binding)
|
|
(error "Initial failure"))))
|
|
(should-not (tp-binding-live-p failed))
|
|
(let ((replacement
|
|
(tp-bind 'owner '(test . failing) (lambda () 42))))
|
|
(should-not (eq failed replacement))
|
|
(should (= (tp-binding-read replacement) 42))))))
|
|
|
|
(ert-deftest tp-binding-test-key-owns-data-and-preserves-opaque-identities ()
|
|
"A retained binding key copies data containers but not identity objects."
|
|
(tp-binding-test--isolated
|
|
(with-temp-buffer
|
|
(let* ((caller-string (copy-sequence "binding"))
|
|
(caller-vector (vector (copy-sequence "key")))
|
|
(record (tp--make-native-range (current-buffer) :buffer 1 1))
|
|
(calls 0)
|
|
(callback (lambda () (cl-incf calls)))
|
|
(table (make-hash-table :test #'equal))
|
|
(marker (copy-marker (point-min)))
|
|
(key (list 'test caller-string caller-vector record callback
|
|
table marker (current-buffer)))
|
|
(binding (tp-bind 'owner key (lambda () 1)))
|
|
(stored (tp-binding-key binding)))
|
|
(should-not (eq stored key))
|
|
(should-not (eq (nth 1 stored) caller-string))
|
|
(should-not (eq (nth 2 stored) caller-vector))
|
|
(should-not (eq (aref (nth 2 stored) 0) (aref caller-vector 0)))
|
|
(should (eq (nth 3 stored) record))
|
|
(should (eq (nth 4 stored) callback))
|
|
(should (eq (nth 5 stored) table))
|
|
(should (eq (nth 6 stored) marker))
|
|
(should (eq (nth 7 stored) (current-buffer)))
|
|
(should (= calls 0))
|
|
(aset caller-string 0 ?B)
|
|
(aset (aref caller-vector 0) 0 ?K)
|
|
(should (equal (nth 1 stored) "binding"))
|
|
(should (equal (nth 2 stored) ["key"]))))))
|
|
|
|
(ert-deftest tp-binding-test-cycle-error-reports-binding-path ()
|
|
"A binding dependency cycle reports the keys in cycle order."
|
|
(tp-binding-test--isolated
|
|
(let ((switch (tp-signal-create nil)) first second)
|
|
(setq first
|
|
(tp-bind 'first-owner '(test . first)
|
|
(lambda ()
|
|
(if (tp-signal-read switch)
|
|
(tp-binding-read second)
|
|
1))))
|
|
(setq second
|
|
(tp-bind 'second-owner '(test . second)
|
|
(lambda () (1+ (tp-binding-read first)))))
|
|
(let ((failure
|
|
(should-error (tp-signal-set switch t)
|
|
:type 'tp-binding-cycle)))
|
|
(should
|
|
(equal (cadr failure)
|
|
'((test . first) (test . second) (test . first)))))
|
|
(should-not (tp-signal-peek switch))
|
|
(should (= (tp-binding-read first) 1))
|
|
(should (= (tp-binding-read second) 2)))))
|
|
|
|
(ert-deftest tp-binding-test-cycle-error-cannot-mutate-retained-keys ()
|
|
"Cycle diagnostics return data copies instead of retained binding keys."
|
|
(tp-binding-test--isolated
|
|
(let* ((switch (tp-signal-create nil))
|
|
(first-key
|
|
(list 'test (copy-sequence "first")
|
|
(vector (copy-sequence "path"))))
|
|
(second-key
|
|
(list 'test (copy-sequence "second")
|
|
(vector (copy-sequence "path"))))
|
|
first second)
|
|
(setq first
|
|
(tp-bind 'first-owner first-key
|
|
(lambda ()
|
|
(if (tp-signal-read switch)
|
|
(tp-binding-read second)
|
|
1))))
|
|
(setq second
|
|
(tp-bind 'second-owner second-key
|
|
(lambda () (1+ (tp-binding-read first)))))
|
|
(let* ((failure
|
|
(should-error (tp-signal-set switch t)
|
|
:type 'tp-binding-cycle))
|
|
(reported-first (car (cadr failure))))
|
|
(aset (nth 1 reported-first) 0 ?F)
|
|
(aset (aref (nth 2 reported-first) 0) 0 ?P)
|
|
(should (equal (nth 1 (tp-binding-key first)) "first"))
|
|
(should (equal (nth 2 (tp-binding-key first)) ["path"]))))))
|
|
|
|
(ert-deftest tp-binding-test-participant-key-is-owned-by-transaction ()
|
|
"Transaction participant keys cannot follow caller container mutation."
|
|
(tp-binding-test--isolated
|
|
(let* ((caller-string (copy-sequence "participant"))
|
|
(caller-vector (vector (copy-sequence "key")))
|
|
(key (list 'test caller-string caller-vector)))
|
|
(tp-with-transaction
|
|
(tp-transaction-participate key #'ignore #'ignore)
|
|
(let ((stored (tp--transaction-participant-key
|
|
(car tp--transaction-participants))))
|
|
(should-not (eq (nth 1 stored) caller-string))
|
|
(should-not (eq (nth 2 stored) caller-vector))
|
|
(should-not (eq (aref (nth 2 stored) 0)
|
|
(aref caller-vector 0)))
|
|
(aset caller-string 0 ?P)
|
|
(aset (aref caller-vector 0) 0 ?K)
|
|
(should (equal (nth 1 stored) "participant"))
|
|
(should (equal (nth 2 stored) ["key"]))
|
|
(should-error
|
|
(tp-transaction-participate
|
|
(list 'test "participant" ["key"]) #'ignore #'ignore)
|
|
:type 'tp-reactive-error))))))
|
|
|
|
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
|
|
"A dirty target rewires before cycle validation examines its old edges."
|
|
(tp-binding-test--isolated
|
|
(let ((first-mode (tp-signal-create nil))
|
|
(second-mode (tp-signal-create t))
|
|
first second)
|
|
(setq first
|
|
(tp-bind 'first-owner '(test . first)
|
|
(lambda ()
|
|
(if (tp-signal-read first-mode)
|
|
(tp-binding-read second)
|
|
1))))
|
|
(setq second
|
|
(tp-bind 'second-owner '(test . second)
|
|
(lambda ()
|
|
(if (tp-signal-read second-mode)
|
|
(tp-binding-read first)
|
|
2))))
|
|
(tp-with-transaction
|
|
(tp-signal-set second-mode nil)
|
|
(tp-signal-set first-mode t))
|
|
(should (= (tp-binding-read first) 2))
|
|
(should (= (tp-binding-read second) 2)))))
|
|
|
|
(ert-deftest tp-binding-test-buffer-signal-dies-with-its-scope ()
|
|
"Killing a buffer-local source detaches all subscriptions."
|
|
(tp-binding-test--isolated
|
|
(let* ((buffer (generate-new-buffer " *tp-binding-scope*"))
|
|
(signal (tp-signal-create 1 :scope buffer))
|
|
(binding
|
|
(tp-bind 'owner '(test . local)
|
|
(lambda () (tp-signal-read signal)))))
|
|
(should (= (tp-binding-dependency-count binding) 1))
|
|
(kill-buffer buffer)
|
|
(should-not (tp-signal-live-p signal))
|
|
(should (= (tp-binding-dependency-count binding) 0)))))
|
|
|
|
(ert-deftest tp-binding-test-global-signal-can-be-disposed-explicitly ()
|
|
"Explicit disposal releases a global signal's graph edges."
|
|
(tp-binding-test--isolated
|
|
(let* ((signal (tp-signal-create 1))
|
|
(binding
|
|
(tp-bind 'owner '(test . global)
|
|
(lambda () (tp-signal-read signal)))))
|
|
(tp-signal-dispose signal)
|
|
(should-not (tp-signal-live-p signal))
|
|
(should (= (tp-signal-subscriber-count signal) 0))
|
|
(should (= (tp-binding-dependency-count binding) 0)))))
|
|
|
|
(ert-deftest tp-binding-test-variable-adapter-separates-global-and-buffer-scope ()
|
|
"Variable adapters route global and buffer-local writes precisely."
|
|
(tp-binding-test--isolated
|
|
(let* ((symbol 'tp-binding-test-variable)
|
|
(buffer (generate-new-buffer " *tp-binding-variable*"))
|
|
(global-calls 0)
|
|
(local-calls 0))
|
|
(unwind-protect
|
|
(progn
|
|
(set symbol 1)
|
|
(with-current-buffer buffer
|
|
(set (make-local-variable symbol) 10))
|
|
(let ((global (tp-variable-signal symbol))
|
|
(local (tp-variable-signal symbol buffer)))
|
|
(tp-bind 'global-owner '(test . global)
|
|
(lambda ()
|
|
(cl-incf global-calls)
|
|
(tp-signal-read global)))
|
|
(tp-bind 'local-owner '(test . local)
|
|
(lambda ()
|
|
(cl-incf local-calls)
|
|
(tp-signal-read local)))
|
|
(set symbol 2)
|
|
(should (= global-calls 2))
|
|
(should (= local-calls 1))
|
|
(with-current-buffer buffer
|
|
(set symbol 11))
|
|
(should (= global-calls 2))
|
|
(should (= local-calls 2))))
|
|
(when (buffer-live-p buffer) (kill-buffer buffer))
|
|
(makunbound symbol)))))
|
|
|
|
(ert-deftest tp-binding-test-precomputed-keeps-explicit-edge-reactive ()
|
|
"A precomputed binding skips first compute and reacts through its edge."
|
|
(let* ((signal (tp-signal-create 1))
|
|
(parent (tp-bind 'parent 'value (lambda () (tp-signal-read signal))))
|
|
(runs 0)
|
|
(child
|
|
(tp-bind-precomputed
|
|
'child 'value
|
|
(lambda () (cl-incf runs) (1+ (tp-binding-read parent)))
|
|
2 (list parent))))
|
|
(should (= (tp-binding-read child) 2))
|
|
(should (= runs 0))
|
|
(should (= (tp-binding-dependency-count child) 1))
|
|
(tp-signal-set signal 4)
|
|
(should (= (tp-binding-read child) 5))
|
|
(should (= runs 1))))
|
|
|
|
(provide 'tp-binding-tests)
|
|
;;; tp-binding-tests.el ends here
|