From 7632a05bdfe4eb26f1749c4185c446d109af3a28 Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Mon, 31 Aug 2026 17:49:33 +0800 Subject: [PATCH] test: lock M0a transaction fault behavior --- Makefile | 10 +- tests/tp-m0a-characterization-tests.el | 188 +++++++++++++++++++++++++ 2 files changed, 197 insertions(+), 1 deletion(-) create mode 100644 tests/tp-m0a-characterization-tests.el diff --git a/Makefile b/Makefile index cd9631f..2318810 100644 --- a/Makefile +++ b/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 diff --git a/tests/tp-m0a-characterization-tests.el b/tests/tp-m0a-characterization-tests.el new file mode 100644 index 0000000..6e734a8 --- /dev/null +++ b/tests/tp-m0a-characterization-tests.el @@ -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