test: lock M0a transaction fault behavior

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

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