tp/tests/tp-char-tests.el

;;; tp-char-tests.el --- Character lookup tests for tp.el -*- lexical-binding: t -*-

;;; Commentary:

;; Stage 5 tests for `tp-lookup' character-property modes.  These tests use
;; GNU Emacs public primitives as the oracle for overlay-aware behavior.

;;; Code:

(require 'ert)
(require 'cl-lib)
(require 'tp)
(require 'tp-query)

(defun tp-char-tests--source-result (position property)
  "Return `tp-lookup' result for PROPERTY at POSITION in `:char-source' mode."
  (tp-lookup position property :mode :char-source))

(ert-deftest tp-char-test-char-mode-returns-overlay-only-value ()
  "The :char lookup mode returns the native overlay-only char property."
  (with-temp-buffer
    (insert "x")
    (let ((overlay (make-overlay 1 2)))
      (overlay-put overlay 'state 'overlay-only)
      (let ((result (tp-lookup 1 'state :mode :char)))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result)
                    (get-char-property 1 'state)))
        (should (eq (tp-lookup-result-value result) 'overlay-only))
        (should (eq (tp-lookup-result-mode result) :char))))))

(ert-deftest tp-char-test-char-source-reports-winning-overlay-identity ()
  "The :char-source lookup mode reports the native winning overlay."
  (with-temp-buffer
    (insert "x")
    (let ((low (make-overlay 1 2))
          (high (make-overlay 1 2)))
      (overlay-put low 'priority 1)
      (overlay-put low 'state 'low)
      (overlay-put high 'priority 10)
      (overlay-put high 'state 'high)
      (let* ((native (get-char-property-and-overlay 1 'state))
             (result (tp-char-tests--source-result 1 'state)))
        (should (eq (car native) 'high))
        (should (eq (cdr native) high))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result) (car native)))
        (should (eq (tp-lookup-result-source result) :overlay))
        (should (eq (tp-lookup-result-overlay result) (cdr native)))))))

(ert-deftest tp-char-test-text-effective-ignores-overlay-value ()
  "The :text-effective lookup mode ignores overlay properties."
  (with-temp-buffer
    (insert "x")
    (put-text-property 1 2 'state 'text)
    (let ((overlay (make-overlay 1 2)))
      (overlay-put overlay 'state 'overlay)
      (let ((result (tp-lookup 1 'state :mode :text-effective)))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result)
                    (get-text-property 1 'state)))
        (should (eq (tp-lookup-result-value result) 'text))))))

(ert-deftest tp-char-test-text-source-direct-nil-stops-fallback ()
  "The :text-source lookup mode treats explicit nil text as present."
  (with-temp-buffer
    (insert "x")
    (let ((category (make-symbol "tp-char-category"))
          (default-text-properties '(state default)))
      (put category 'state 'category)
      (put-text-property 1 2 'category category)
      (put-text-property 1 2 'state nil)
      (let ((result (tp-lookup 1 'state :mode :text-source)))
        (should (tp-lookup-result-present-p result))
        (should-not (tp-lookup-result-value result))
        (should (eq (tp-lookup-result-source result) :text-direct))))))

(ert-deftest tp-char-test-text-source-classifies-category-source ()
  "The :text-source lookup mode classifies category fallback."
  (with-temp-buffer
    (insert "x")
    (let ((category (make-symbol "tp-char-category")))
      (put category 'state 'category)
      (put-text-property 1 2 'category category)
      (let ((result (tp-lookup 1 'state :mode :text-source)))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result) 'category))
        (should (eq (tp-lookup-result-source result) :category))))))

(ert-deftest tp-char-test-text-source-classifies-alias-source ()
  "The :text-source lookup mode classifies alias fallback."
  (with-temp-buffer
    (insert "x")
    (let ((char-property-alias-alist '((state alternate))))
      (put-text-property 1 2 'alternate 'alias)
      (let ((result (tp-lookup 1 'state :mode :text-source)))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result) 'alias))
        (should (eq (tp-lookup-result-source result) :alias))))))

(ert-deftest tp-char-test-text-source-classifies-default-source ()
  "The :text-source lookup mode classifies default fallback."
  (with-temp-buffer
    (insert "x")
    (let ((default-text-properties '(state default)))
      (let ((result (tp-lookup 1 'state :mode :text-source)))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result) 'default))
        (should (eq (tp-lookup-result-source result) :default))))))

(ert-deftest tp-char-test-text-source-classifies-absent-source ()
  "The :text-source lookup mode classifies absent properties."
  (with-temp-buffer
    (insert "x")
    (let ((result (tp-lookup 1 'state :mode :text-source)))
      (should-not (tp-lookup-result-present-p result))
      (should-not (tp-lookup-result-value result))
      (should (eq (tp-lookup-result-source result) :absent)))))

(ert-deftest tp-char-test-char-source-follows-native-overlay-nil-fallback ()
  "The :char-source lookup mode follows native explicit nil overlay fallback."
  (with-temp-buffer
    (insert "x")
    (put-text-property 1 2 'state 'text)
    (let ((overlay (make-overlay 1 2)))
      (overlay-put overlay 'state nil)
      (let* ((native (get-char-property-and-overlay 1 'state))
             (result (tp-char-tests--source-result 1 'state)))
        (should (eq (car native) 'text))
        (should-not (cdr native))
        (should (tp-lookup-result-present-p result))
        (should (eq (tp-lookup-result-value result) (car native)))
        (should-not (tp-lookup-result-overlay result))))))

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