;;; 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