test: lock M0a transaction fault behavior
This commit is contained in:
Kinneyzhang
parent
c2525a137b
commit
7632a05bdf
10
Makefile
10
Makefile
@ -3,6 +3,7 @@
|
||||
# Usage:
|
||||
# make test # run all ERT test suites
|
||||
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
|
||||
# make test-m0a # run current TP completion characterization
|
||||
# make doctest # execute README examples against the code
|
||||
# make benchmark # run reproducible correctness-first benchmarks
|
||||
# make compile # byte-compile the library modules
|
||||
@ -28,12 +29,19 @@ TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
|
||||
EXAMPLES = $(wildcard examples/*.el)
|
||||
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
|
||||
|
||||
.PHONY: test test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
|
||||
.PHONY: test test-m0a test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
|
||||
|
||||
test:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||
-f ert-run-tests-batch-and-exit
|
||||
|
||||
test-m0a:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||
-l $(TEST_DIR)/tp-binding-tests.el \
|
||||
-l $(TEST_DIR)/tp-surface-tests.el \
|
||||
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
|
||||
--eval '(ert-run-tests-batch-and-exit "tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
|
||||
|
||||
test-shuffled:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||
-l tp-run-shuffled.el
|
||||
|
||||
188
tests/tp-m0a-characterization-tests.el
Normal file
188
tests/tp-m0a-characterization-tests.el
Normal file
@ -0,0 +1,188 @@
|
||||
;;; tp-m0a-characterization-tests.el --- Current TP completion semantics -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Geekinney
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Focused M0a characterization tests for completion semantics that are
|
||||
;; already implemented. Future structured batches and final markers do not
|
||||
;; belong in this baseline.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'tp-surface)
|
||||
|
||||
(define-error 'tp-m0a-characterization-error
|
||||
"Injected TP M0a characterization failure")
|
||||
|
||||
(defvar tp-m0a-characterization--precommit-condition nil
|
||||
"Condition injected by the M0a precommit test hook.")
|
||||
|
||||
(defun tp--m0a-characterization-precommit-inject ()
|
||||
"Signal `tp-m0a-characterization--precommit-condition'."
|
||||
(when tp-m0a-characterization--precommit-condition
|
||||
(signal (car tp-m0a-characterization--precommit-condition)
|
||||
(cdr tp-m0a-characterization--precommit-condition))))
|
||||
|
||||
(defun tp-m0a-characterization--leaf (text)
|
||||
"Return a retained content leaf displaying TEXT."
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'text :text text :capability 'content))
|
||||
|
||||
(defun tp-m0a-characterization--producer (source)
|
||||
"Return a retained content producer reading SOURCE."
|
||||
(lambda (context)
|
||||
(tp-object-ensure context nil 'root 'text)
|
||||
(tp-m0a-characterization--leaf
|
||||
(number-to-string (tp-signal-read source)))))
|
||||
|
||||
(defun tp-m0a-characterization--capture (function)
|
||||
"Call FUNCTION and return its signaled condition."
|
||||
(condition-case condition
|
||||
(progn (funcall function) nil)
|
||||
(tp-m0a-characterization-error condition)))
|
||||
|
||||
(cl-defmacro tp-m0a-characterization--with-surface
|
||||
((buffer surface source) &rest body)
|
||||
"Create BUFFER, SOURCE, and SURFACE, then evaluate BODY."
|
||||
(declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
|
||||
`(let* ((,buffer (generate-new-buffer " *tp-m0a-characterization*"))
|
||||
(,source (tp-signal-create 1))
|
||||
(,surface
|
||||
(tp-surface-mount
|
||||
,buffer (tp-m0a-characterization--producer ,source)
|
||||
'(:capability content))))
|
||||
(unwind-protect
|
||||
(progn ,@body)
|
||||
(when (buffer-live-p ,buffer)
|
||||
(kill-buffer ,buffer))
|
||||
(when (tp-signal-live-p ,source)
|
||||
(tp-signal-dispose ,source)))))
|
||||
|
||||
(ert-deftest tp-m0a-characterization-test-first-surface-failure-rolls-back-batch ()
|
||||
"A first-surface failure restores every surface and the source state."
|
||||
(let* ((source (tp-signal-create 1))
|
||||
(producer (tp-m0a-characterization--producer source))
|
||||
(first-buffer (generate-new-buffer " *tp-m0a-first*"))
|
||||
(second-buffer (generate-new-buffer " *tp-m0a-second*"))
|
||||
(first (tp-surface-mount
|
||||
first-buffer producer '(:capability content)))
|
||||
(second (tp-surface-mount
|
||||
second-buffer producer '(:capability content)))
|
||||
(first-revision (tp-surface-revision first))
|
||||
(second-revision (tp-surface-revision second))
|
||||
(injected '(tp-m0a-characterization-error
|
||||
:phase first-surface :payload (1 2 3)))
|
||||
(tp--surface-publication-step-function
|
||||
(lambda (step surface)
|
||||
(when (and (eq step 'client-state) (eq surface first))
|
||||
(signal (car injected) (cdr injected))))))
|
||||
(unwind-protect
|
||||
(let ((failure
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda () (tp-signal-set source 2)))))
|
||||
(should (equal failure injected))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-signal-revision source) 0))
|
||||
(should (= (tp-surface-revision first) first-revision))
|
||||
(should (= (tp-surface-revision second) second-revision))
|
||||
(with-current-buffer first-buffer
|
||||
(should (equal (buffer-string) "1")))
|
||||
(with-current-buffer second-buffer
|
||||
(should (equal (buffer-string) "1"))))
|
||||
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
||||
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
||||
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
||||
|
||||
(ert-deftest tp-m0a-characterization-test-participant-failure-preserves-condition ()
|
||||
"A participant failure preserves raw condition data and restores all owners."
|
||||
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||
(let ((external 'old)
|
||||
(revision (tp-surface-revision surface))
|
||||
(injected '(tp-m0a-characterization-error
|
||||
:phase participant :payload [raw data])))
|
||||
(let ((failure
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda ()
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'm0a-participant
|
||||
(lambda ()
|
||||
(setq external 'candidate)
|
||||
(signal (car injected) (cdr injected)))
|
||||
(lambda () (setq external 'old)))
|
||||
(tp-signal-set source 2))))))
|
||||
(should (equal failure injected)))
|
||||
(should (eq external 'old))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-signal-revision source) 0))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1"))))))
|
||||
|
||||
(ert-deftest tp-m0a-characterization-test-precommit-failure-preserves-condition ()
|
||||
"A precommit failure preserves raw condition data and restores publication."
|
||||
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||
(let* ((revision (tp-surface-revision surface))
|
||||
(injected '(tp-m0a-characterization-error
|
||||
:phase precommit :payload (raw data)))
|
||||
(tp--transaction-precommit-functions
|
||||
'(tp--m0a-characterization-precommit-inject))
|
||||
(tp--transaction-precommit-allowed-functions
|
||||
'(tp--m0a-characterization-precommit-inject))
|
||||
(tp-m0a-characterization--precommit-condition injected)
|
||||
(failure
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda () (tp-signal-set source 2)))))
|
||||
(should (equal failure injected))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-signal-revision source) 0))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1"))))))
|
||||
|
||||
(ert-deftest tp-m0a-characterization-test-signal-commit-failure-preserves-condition ()
|
||||
"A signal commit failure preserves raw condition data and restores publication."
|
||||
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||
(let ((revision (tp-surface-revision surface))
|
||||
(injected '(tp-m0a-characterization-error
|
||||
:phase signal :payload (:raw data)))
|
||||
(original (symbol-function 'tp--commit-signal-entry)))
|
||||
(let ((failure
|
||||
(cl-letf (((symbol-function 'tp--commit-signal-entry)
|
||||
(lambda (entry)
|
||||
(funcall original entry)
|
||||
(signal (car injected) (cdr injected)))))
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda () (tp-signal-set source 2))))))
|
||||
(should (equal failure injected)))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-signal-revision source) 0))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1"))))))
|
||||
|
||||
(ert-deftest tp-m0a-characterization-test-final-accept-failure-preserves-condition ()
|
||||
"A final-accept failure preserves raw condition data and restores publication."
|
||||
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||
(let ((revision (tp-surface-revision surface))
|
||||
(injected '(tp-m0a-characterization-error
|
||||
:phase final-accept :payload ((raw . data)))))
|
||||
(let ((failure
|
||||
(cl-letf (((symbol-function 'accept-change-group)
|
||||
(lambda (_group)
|
||||
(signal (car injected) (cdr injected)))))
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda () (tp-signal-set source 2))))))
|
||||
(should (equal failure injected)))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
(should (= (tp-signal-revision source) 0))
|
||||
(should (= (tp-surface-revision surface) revision))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1"))))))
|
||||
|
||||
(provide 'tp-m0a-characterization-tests)
|
||||
|
||||
;;; tp-m0a-characterization-tests.el ends here
|
||||
Loading…
Reference in New Issue
Block a user