189 lines
8.3 KiB
EmacsLisp
189 lines
8.3 KiB
EmacsLisp
;;; 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-v2
|
|
:key 'm0a-participant
|
|
:stage (lambda ()
|
|
(setq external 'candidate)
|
|
(signal (car injected) (cdr injected)))
|
|
:rollback (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
|