;;; tp-binding-tests.el --- Tests for TP binding graph -*- lexical-binding: t; -*-

;; Copyright (C) 2026 Geekinney

;;; Commentary:

;; Contract tests for TP 1.0 signals, bindings, and transactions.

;;; Code:

(require 'ert)
(require 'tp-reactive)

(defvar tp-binding-test-variable nil
  "Variable used by scoped signal adapter tests.")

(defmacro tp-binding-test--isolated (&rest body)
  "Run BODY with an isolated reactive runtime."
  (declare (indent 0) (debug t))
  `(progn
     (tp-reactive-reset)
     (unwind-protect (progn ,@body)
       (tp-reactive-reset))))

(ert-deftest tp-binding-test-signal-invalidates-only-direct-subscribers ()
  "A sparse signal write never visits unrelated bindings."
  (tp-binding-test--isolated
    (let ((target (tp-signal-create 0))
          (unrelated (tp-signal-create 0))
          (target-calls 0)
          (unrelated-calls 0))
      (tp-with-transaction
        (tp-bind 'target-owner '(test . value)
                 (lambda ()
                   (cl-incf target-calls)
                   (tp-signal-read target)))
        (dotimes (index 9999)
          (tp-bind (list 'unrelated-owner index) '(test . value)
                   (lambda ()
                     (cl-incf unrelated-calls)
                     (tp-signal-read unrelated)))))
      (should (= target-calls 1))
      (should (= unrelated-calls 9999))
      (tp-reactive-reset-counters)
      (cl-letf (((symbol-function 'buffer-list)
                 (lambda (&rest _) (error "Legacy scan")))
                ((symbol-function 'text-property-search-forward)
                 (lambda (&rest _) (error "Legacy scan")))
                ((symbol-function 'tp-reactive--buffer-layer-names)
                 (lambda (&rest _) (error "Legacy scan")))
                ((symbol-function 'tp-reactive-layer-buffers)
                 (lambda (&rest _) (error "Legacy scan"))))
        (tp-signal-set target 1))
      (should (= target-calls 2))
      (should (= unrelated-calls 9999))
      (should (equal (tp-reactive-counters)
                     '(:invalidated 1 :recomputed 1 :skipped 0
                       :subscription-added 0 :subscription-removed 0))))))

(ert-deftest tp-binding-test-conditional-dependencies-rewire ()
  "A binding unsubscribes from the branch it no longer reads."
  (tp-binding-test--isolated
    (let ((enabled (tp-signal-create t))
          (active (tp-signal-create 'active))
          (disabled (tp-signal-create 'disabled))
          (calls 0))
      (tp-bind 'owner '(test . branch)
               (lambda ()
                 (cl-incf calls)
                 (if (tp-signal-read enabled)
                     (tp-signal-read active)
                   (tp-signal-read disabled))))
      (tp-signal-set enabled nil)
      (should (= calls 2))
      (tp-signal-set active 'ignored)
      (should (= calls 2))
      (tp-signal-set disabled 'changed)
      (should (= calls 3)))))

(ert-deftest tp-binding-test-equal-signal-write-is-noop ()
  "Setting an equal signal value does not dirty its binding."
  (tp-binding-test--isolated
    (let ((source (tp-signal-create '(1 2) :equality #'equal))
          (calls 0))
      (tp-bind 'owner '(test . value)
               (lambda ()
                 (cl-incf calls)
                 (tp-signal-read source)))
      (tp-reactive-reset-counters)
      (tp-signal-set source (list 1 2))
      (should (= calls 1))
      (should (equal (tp-reactive-counters)
                     '(:invalidated 0 :recomputed 0 :skipped 0
                       :subscription-added 0 :subscription-removed 0))))))

(ert-deftest tp-binding-test-transaction-deduplicates-writes ()
  "Repeated writes in one transaction recompute each binding once."
  (tp-binding-test--isolated
    (let ((source (tp-signal-create 0))
          (calls 0))
      (tp-bind 'owner '(test . value)
               (lambda ()
                 (cl-incf calls)
                 (tp-signal-read source)))
      (tp-reactive-reset-counters)
      (tp-with-transaction
        (dotimes (value 100)
          (tp-signal-set source (1+ value))))
      (should (= (tp-signal-peek source) 100))
      (should (= calls 2))
      (should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))

(ert-deftest tp-binding-test-nested-write-queues-a-second-pass ()
  "A compute write queues stabilization instead of recursing."
  (tp-binding-test--isolated
    (let ((source (tp-signal-create 0))
          (calls 0))
      (let ((binding
             (tp-bind 'owner '(test . stabilizing)
                      (lambda ()
                        (cl-incf calls)
                        (let ((value (tp-signal-read source)))
                          (when (zerop value)
                            (tp-signal-set source 1))
                          value)))))
        (should (= (tp-binding-read binding) 1))
        (should (= (tp-signal-peek source) 1))
        (should (= calls 2))))))

(ert-deftest tp-binding-test-chain-stops-at-equal-computed-value ()
  "An equal intermediate value prevents downstream recomputation."
  (tp-binding-test--isolated
    (let* ((source (tp-signal-create 10))
           (middle-calls 0)
           (leaf-calls 0)
           (middle
            (tp-bind 'middle-owner '(test . quotient)
                     (lambda ()
                       (cl-incf middle-calls)
                       (/ (tp-signal-read source) 10))))
           (_leaf
            (tp-bind 'leaf-owner '(test . display)
                     (lambda ()
                       (cl-incf leaf-calls)
                       (format "%s" (tp-binding-read middle))))))
      (tp-signal-set source 11)
      (should (= middle-calls 2))
      (should (= leaf-calls 1))
      (tp-signal-set source 20)
      (should (= middle-calls 3))
      (should (= leaf-calls 2)))))

(ert-deftest tp-binding-test-owner-disposal-cleans-graph-edges ()
  "Disposing an owner removes all incoming and outgoing subscriptions."
  (tp-binding-test--isolated
    (let* ((source (tp-signal-create 1))
           (owner (list 'owner))
           (base (tp-bind owner '(test . base)
                          (lambda () (tp-signal-read source))))
           (derived (tp-bind owner '(test . derived)
                             (lambda () (1+ (tp-binding-read base))))))
      (should (= (tp-signal-subscriber-count source) 1))
      (should (= (tp-binding-subscriber-count base) 1))
      (should (= (tp-binding-dependency-count derived) 1))
      (tp-binding-dispose-owner owner)
      (should (= (tp-signal-subscriber-count source) 0))
      (should (= (tp-binding-subscriber-count base) 0))
      (should-not (tp-binding-live-p base))
      (should-not (tp-binding-live-p derived)))))

(ert-deftest tp-binding-test-failed-compute-rolls-back-values-and-dependencies ()
  "A failed transaction restores signal, binding, and dependency state."
  (tp-binding-test--isolated
    (let* ((switch (tp-signal-create t))
           (left (tp-signal-create 10))
           (right (tp-signal-create 20))
           (binding
            (tp-bind 'owner '(test . branch)
                     (lambda ()
                       (if (tp-signal-read switch)
                           (tp-signal-read left)
                         (progn
                           (tp-signal-read right)
                           (error "Broken branch")))))))
      (let ((counters-before (tp-reactive-counters)))
        (should-error (tp-signal-set switch nil) :type 'error)
        (should (equal (tp-reactive-counters) counters-before)))
      (should (tp-signal-peek switch))
      (should (= (tp-binding-read binding) 10))
      (should (= (tp-signal-subscriber-count left) 1))
      (should (= (tp-signal-subscriber-count right) 0))
      (tp-signal-set left 11)
      (should (= (tp-binding-read binding) 11)))))

(ert-deftest tp-binding-test-failed-new-binding-is-unregistered ()
  "A failed initial compute invalidates and unregisters the new binding."
  (tp-binding-test--isolated
    (let (failed)
      (should-error
       (tp-bind 'owner '(test . failing)
                (lambda ()
                  (setq failed tp--current-binding)
                  (error "Initial failure"))))
      (should-not (tp-binding-live-p failed))
      (let ((replacement
             (tp-bind 'owner '(test . failing) (lambda () 42))))
        (should-not (eq failed replacement))
        (should (= (tp-binding-read replacement) 42))))))

(ert-deftest tp-binding-test-key-owns-data-and-preserves-opaque-identities ()
  "A retained binding key copies data containers but not identity objects."
  (tp-binding-test--isolated
    (with-temp-buffer
      (let* ((caller-string (copy-sequence "binding"))
             (caller-vector (vector (copy-sequence "key")))
             (record (tp--make-native-range (current-buffer) :buffer 1 1))
             (calls 0)
             (callback (lambda () (cl-incf calls)))
             (table (make-hash-table :test #'equal))
             (marker (copy-marker (point-min)))
             (key (list 'test caller-string caller-vector record callback
                        table marker (current-buffer)))
             (binding (tp-bind 'owner key (lambda () 1)))
             (stored (tp-binding-key binding)))
        (should-not (eq stored key))
        (should-not (eq (nth 1 stored) caller-string))
        (should-not (eq (nth 2 stored) caller-vector))
        (should-not (eq (aref (nth 2 stored) 0) (aref caller-vector 0)))
        (should (eq (nth 3 stored) record))
        (should (eq (nth 4 stored) callback))
        (should (eq (nth 5 stored) table))
        (should (eq (nth 6 stored) marker))
        (should (eq (nth 7 stored) (current-buffer)))
        (should (= calls 0))
        (aset caller-string 0 ?B)
        (aset (aref caller-vector 0) 0 ?K)
        (should (equal (nth 1 stored) "binding"))
        (should (equal (nth 2 stored) ["key"]))))))

(ert-deftest tp-binding-test-cycle-error-reports-binding-path ()
  "A binding dependency cycle reports the keys in cycle order."
  (tp-binding-test--isolated
    (let ((switch (tp-signal-create nil)) first second)
      (setq first
            (tp-bind 'first-owner '(test . first)
                     (lambda ()
                       (if (tp-signal-read switch)
                           (tp-binding-read second)
                         1))))
      (setq second
            (tp-bind 'second-owner '(test . second)
                     (lambda () (1+ (tp-binding-read first)))))
      (let ((failure
             (should-error (tp-signal-set switch t)
                           :type 'tp-binding-cycle)))
        (should
         (equal (cadr failure)
                '((test . first) (test . second) (test . first)))))
      (should-not (tp-signal-peek switch))
      (should (= (tp-binding-read first) 1))
      (should (= (tp-binding-read second) 2)))))

(ert-deftest tp-binding-test-cycle-error-cannot-mutate-retained-keys ()
  "Cycle diagnostics return data copies instead of retained binding keys."
  (tp-binding-test--isolated
    (let* ((switch (tp-signal-create nil))
           (first-key
            (list 'test (copy-sequence "first")
                  (vector (copy-sequence "path"))))
           (second-key
            (list 'test (copy-sequence "second")
                  (vector (copy-sequence "path"))))
           first second)
      (setq first
            (tp-bind 'first-owner first-key
                     (lambda ()
                       (if (tp-signal-read switch)
                           (tp-binding-read second)
                         1))))
      (setq second
            (tp-bind 'second-owner second-key
                     (lambda () (1+ (tp-binding-read first)))))
      (let* ((failure
              (should-error (tp-signal-set switch t)
                            :type 'tp-binding-cycle))
             (reported-first (car (cadr failure))))
        (aset (nth 1 reported-first) 0 ?F)
        (aset (aref (nth 2 reported-first) 0) 0 ?P)
        (should (equal (nth 1 (tp-binding-key first)) "first"))
        (should (equal (nth 2 (tp-binding-key first)) ["path"]))))))

(ert-deftest tp-binding-test-participant-key-is-owned-by-transaction ()
  "Transaction participant keys cannot follow caller container mutation."
  (tp-binding-test--isolated
    (let* ((caller-string (copy-sequence "participant"))
           (caller-vector (vector (copy-sequence "key")))
           (key (list 'test caller-string caller-vector)))
      (tp-with-transaction
        (tp-transaction-participate key #'ignore #'ignore)
        (let ((stored (tp--transaction-participant-key
                       (car tp--transaction-participants))))
          (should-not (eq (nth 1 stored) caller-string))
          (should-not (eq (nth 2 stored) caller-vector))
          (should-not (eq (aref (nth 2 stored) 0)
                          (aref caller-vector 0)))
          (aset caller-string 0 ?P)
          (aset (aref caller-vector 0) 0 ?K)
          (should (equal (nth 1 stored) "participant"))
          (should (equal (nth 2 stored) ["key"]))
          (should-error
           (tp-transaction-participate
            (list 'test "participant" ["key"]) #'ignore #'ignore)
           :type 'tp-reactive-error))))))

(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
  "A dirty target rewires before cycle validation examines its old edges."
  (tp-binding-test--isolated
    (let ((first-mode (tp-signal-create nil))
          (second-mode (tp-signal-create t))
          first second)
      (setq first
            (tp-bind 'first-owner '(test . first)
                     (lambda ()
                       (if (tp-signal-read first-mode)
                           (tp-binding-read second)
                         1))))
      (setq second
            (tp-bind 'second-owner '(test . second)
                     (lambda ()
                       (if (tp-signal-read second-mode)
                           (tp-binding-read first)
                         2))))
      (tp-with-transaction
        (tp-signal-set second-mode nil)
        (tp-signal-set first-mode t))
      (should (= (tp-binding-read first) 2))
      (should (= (tp-binding-read second) 2)))))

(ert-deftest tp-binding-test-buffer-signal-dies-with-its-scope ()
  "Killing a buffer-local source detaches all subscriptions."
  (tp-binding-test--isolated
    (let* ((buffer (generate-new-buffer " *tp-binding-scope*"))
           (signal (tp-signal-create 1 :scope buffer))
           (binding
            (tp-bind 'owner '(test . local)
                     (lambda () (tp-signal-read signal)))))
      (should (= (tp-binding-dependency-count binding) 1))
      (kill-buffer buffer)
      (should-not (tp-signal-live-p signal))
      (should (= (tp-binding-dependency-count binding) 0)))))

(ert-deftest tp-binding-test-global-signal-can-be-disposed-explicitly ()
  "Explicit disposal releases a global signal's graph edges."
  (tp-binding-test--isolated
    (let* ((signal (tp-signal-create 1))
           (binding
            (tp-bind 'owner '(test . global)
                     (lambda () (tp-signal-read signal)))))
      (tp-signal-dispose signal)
      (should-not (tp-signal-live-p signal))
      (should (= (tp-signal-subscriber-count signal) 0))
      (should (= (tp-binding-dependency-count binding) 0)))))

(ert-deftest tp-binding-test-variable-adapter-separates-global-and-buffer-scope ()
  "Variable adapters route global and buffer-local writes precisely."
  (tp-binding-test--isolated
    (let* ((symbol 'tp-binding-test-variable)
           (buffer (generate-new-buffer " *tp-binding-variable*"))
           (global-calls 0)
           (local-calls 0))
      (unwind-protect
          (progn
            (set symbol 1)
            (with-current-buffer buffer
              (set (make-local-variable symbol) 10))
            (let ((global (tp-variable-signal symbol))
                  (local (tp-variable-signal symbol buffer)))
              (tp-bind 'global-owner '(test . global)
                       (lambda ()
                         (cl-incf global-calls)
                         (tp-signal-read global)))
              (tp-bind 'local-owner '(test . local)
                       (lambda ()
                         (cl-incf local-calls)
                         (tp-signal-read local)))
              (set symbol 2)
              (should (= global-calls 2))
              (should (= local-calls 1))
              (with-current-buffer buffer
                (set symbol 11))
              (should (= global-calls 2))
              (should (= local-calls 2))))
        (when (buffer-live-p buffer) (kill-buffer buffer))
        (makunbound symbol)))))

(provide 'tp-binding-tests)
;;; tp-binding-tests.el ends here