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

;; Copyright (C) 2026 Geekinney

;;; Commentary:

;; Contract tests for one-shot and reactive text-property conveniences.

;;; Code:

(require 'ert)
(require 'tp)

(ert-deftest tp-convenience-test-propertize-uses-style-projection ()
  "Propertizing projects native declarations without mutating the input."
  (let* ((callback (lambda (_window _object _position) "help"))
         (source "Hello")
         (result
          (tp-propertize
           source
           (list 'face '(:foreground "red" :weight bold)
                 'help-echo callback 'keymap nil))))
    (should (equal source "Hello"))
    (should-not (text-properties-at 0 source))
    (should (equal (get-text-property 0 'face result)
                   '(:foreground "red" :weight bold)))
    (should (eq (get-text-property 0 'help-echo result) callback))
    (should (plist-member (text-properties-at 0 result) 'keymap))
    (should-not (get-text-property 0 'keymap result))))

(ert-deftest tp-convenience-test-apply-mutates-only-the-requested-range ()
  "Applying declarations preserves text and properties outside the range."
  (with-temp-buffer
    (insert "abcdef")
    (put-text-property 1 7 'category 'host)
    (should (equal (tp-apply (current-buffer) 2 5 '(face italic)) '(2 . 5)))
    (should (equal (buffer-string) "abcdef"))
    (should-not (get-text-property 1 'face))
    (should (eq (get-text-property 2 'face) 'italic))
    (should-not (get-text-property 5 'face))
    (should (eq (get-text-property 3 'category) 'host))))

(ert-deftest tp-convenience-test-apply-rejects-invalid-targets-and-ranges ()
  "Applying never falls back from an invalid target to the current buffer."
  (with-temp-buffer
    (insert "safe")
    (should-error (tp-apply " *missing-tp-buffer*" 1 2 '(face bold))
                  :type 'tp-unsupported-buffer)
    (should-error (tp-apply (current-buffer) 4 2 '(face bold))
                  :type 'args-out-of-range)
    (should (equal (buffer-string) "safe"))
    (should-not (text-properties-at 0 (buffer-string)))))

(ert-deftest tp-convenience-test-watch-reacts-and-restores-host-properties ()
  "Watching a range updates properties through one retained surface."
  (with-temp-buffer
    (insert "Status")
    (put-text-property 1 7 'help-echo "host")
    (let* ((connected (tp-signal-create nil))
           (surface
            (tp-watch
             (current-buffer) 1 7
             (lambda ()
               (if (tp-signal-read connected)
                   '(face (:foreground "green") help-echo "Connected")
                 '(face (:foreground "red") help-echo "Disconnected"))))))
      (should (equal (buffer-string) "Status"))
      (should (equal (get-text-property 2 'face)
                     '(:foreground "red")))
      (should (equal (get-text-property 2 'help-echo) "Disconnected"))
      (tp-signal-set connected t)
      (should (equal (get-text-property 2 'face)
                     '(:foreground "green")))
      (should (equal (get-text-property 2 'help-echo) "Connected"))
      (should (= (tp-surface-revision surface) 2))
      (tp-surface-unmount surface)
      (should-not (get-text-property 2 'face))
      (should (equal (get-text-property 2 'help-echo) "host")))))

(ert-deftest tp-convenience-test-failed-watch-releases-its-range-anchor ()
  "A failed first watch publication leaves no live marker-backed anchor."
  (with-temp-buffer
    (insert "host")
    (let ((original (symbol-function 'tp-range-anchor-create))
          anchor)
      (cl-letf (((symbol-function 'tp-range-anchor-create)
                 (lambda (&rest arguments)
                   (setq anchor (apply original arguments)))))
        (should-error
         (tp-watch (current-buffer) 1 5
                   (lambda () (error "Initial compute failed")))))
      (should-not (tp-range-anchor-live-p anchor)))))

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