;;; tp-native-tests.el --- Native text-property equivalence tests -*- lexical-binding: t -*-

;;; Commentary:

;; Stage 3/5 tests for the explicit GNU Emacs text/character property
;; compatibility boundary.  Tests compare tp entry points with public Emacs
;; primitives rather than duplicating their expected implementation.

;;; Code:

(require 'ert)
(require 'tp)

(ert-deftest tp-native-test-lookup-direct-presence-states ()
  "Direct lookup distinguishes absence, explicit nil, and a value."
  (let ((str (copy-sequence "abc")))
    (put-text-property 0 1 'state nil str)
    (put-text-property 1 2 'state 'ready str)
    (let ((nil-value (tp-lookup 0 'state :object str :mode :text-direct))
          (value (tp-lookup 1 'state :object str :mode :text-direct))
          (absent (tp-lookup 2 'state :object str :mode :text-direct)))
      (should (tp-lookup-result-present-p nil-value))
      (should-not (tp-lookup-result-value nil-value))
      (should (eq (tp-lookup-result-source nil-value) :text-direct))
      (should (tp-lookup-result-present-p value))
      (should (eq (tp-lookup-result-value value) 'ready))
      (should-not (tp-lookup-result-present-p absent))
      (should (eq (tp-lookup-result-source absent) :absent)))))

(ert-deftest tp-native-test-lookup-effective-source-matrix ()
  "Source lookup explains direct, category, alias, and default values.
Like native lookup, a nil alias value falls through to the default."
  (let* ((str (copy-sequence "abcd"))
         (category (make-symbol "tp-native-category"))
         (char-property-alias-alist '((state alternate)))
         (default-text-properties '(state default)))
    (put category 'state 'category)
    (put-text-property 0 1 'state nil str)
    (put-text-property 1 2 'category category str)
    (put-text-property 2 3 'alternate 'alias str)
    (put-text-property 3 4 'alternate nil str)
    (dolist (case '((0 nil :text-direct)
                    (1 category :category)
                    (2 alias :alias)
                    (3 default :default)))
      (pcase-let ((`(,position ,value ,source) case))
        (let ((result (tp-lookup
                       position 'state :object str :mode :text-source)))
          (should (tp-lookup-result-present-p result))
          (should (equal (tp-lookup-result-value result) value))
          (should (eq (tp-lookup-result-source result) source))
          (should (equal
                   (tp-lookup-result-value
                    (tp-lookup position 'state
                               :object str :mode :text-effective))
                   (get-text-property position 'state str))))))))

(ert-deftest tp-native-test-property-change-matches-emacs ()
  "Single/all and next/previous change queries match Emacs primitives."
  (let ((str (copy-sequence "abcdef")))
    (put-text-property 0 3 'state 1 str)
    (put-text-property 3 6 'state 2 str)
    (put-text-property 1 2 'unrelated t str)
    (should (equal
             (tp-property-change
              0 :property 'state :object str :limit 6 :direction :next)
             (next-single-property-change 0 'state str 6)))
    (should (equal
             (tp-property-change 0 :object str :limit 6 :direction :next)
             (next-property-change 0 str 6)))
    (should (equal
             (tp-property-change
              6 :property 'state :object str :limit 0 :direction :previous)
             (previous-single-property-change 6 'state str 0)))
    (should (equal
             (tp-property-change 6 :object str :limit 0 :direction :previous)
             (previous-property-change 6 str 0)))))

(ert-deftest tp-native-test-property-any-not-all-match-emacs ()
  "Region equality predicates preserve exact nil behavior."
  (let ((str (copy-sequence "abcd")))
    (put-text-property 0 2 'state nil str)
    (put-text-property 2 4 'state 'ready str)
    (dolist (value '(nil ready missing))
      (should (equal (tp-property-any 0 4 'state value str)
                     (text-property-any 0 4 'state value str)))
      (should (equal (tp-property-not-all 0 4 'state value str)
                     (text-property-not-all 0 4 'state value str))))))

(ert-deftest tp-native-test-mutation-policy-respect-and-inhibit ()
  "Read-only override is explicit and ordinary mode records changes."
  (with-temp-buffer
    (insert "abc")
    (put-text-property 1 2 'read-only t)
    (should-error
     (tp-with-mutation-policy
         '(:modified :ordinary :read-only :respect)
       (tp-set 1 2 '(face bold))))
    (tp-with-mutation-policy
        '(:modified :ordinary :read-only :inhibit)
      (tp-set 1 2 '(face bold)))
    (should (eq (get-text-property 1 'face) 'bold)))
  (with-temp-buffer
    (buffer-enable-undo)
    (insert "abc")
    (setq buffer-undo-list nil)
    (set-buffer-modified-p nil)
    (tp-with-mutation-policy
        '(:modified :ordinary :read-only :respect)
      (tp-set 1 2 '(face bold)))
    (should (buffer-modified-p))
    (should (consp buffer-undo-list))))

(ert-deftest tp-native-test-mutation-policy-silent ()
  "Silent property writes keep modified and undo state unchanged."
  (with-temp-buffer
    (buffer-enable-undo)
    (insert "abc")
    (setq buffer-undo-list nil)
    (set-buffer-modified-p nil)
    (tp-with-mutation-policy
        '(:modified :silent :read-only :inhibit)
      (tp-set 1 2 '(face bold)))
    (should (eq (get-text-property 1 'face) 'bold))
    (should-not (buffer-modified-p))
    (should-not buffer-undo-list))
  (should-error
   (tp-with-mutation-policy
       '(:modified :silent :read-only :respect)
     nil))
  (should-error
   (tp-with-mutation-policy '(:unknown t) nil))
  (should-error
   (tp-with-mutation-policy '(:modified nil) nil))
  (should-error
   (tp-with-mutation-policy '(:modified) nil)))

(ert-deftest tp-native-test-stickiness-and-insertion-delegation ()
  "tp-set properties retain native insert and insert-and-inherit behavior."
  (with-temp-buffer
    (insert "ab")
    (tp-set 1 2 '(face bold))
    (goto-char 2)
    (insert "x")
    (should-not (get-text-property 2 'face)))
  (with-temp-buffer
    (insert "ab")
    (tp-set 1 2 '(face bold))
    (goto-char 2)
    (insert-and-inherit "x")
    (should (eq (get-text-property 2 'face) 'bold))))

(ert-deftest tp-native-test-copy-insert-and-yank-filtering ()
  "Copy and yank primitives preserve/filter tp-applied properties natively."
  (let* ((source (tp-set "abcd" 'face 'bold 'secret 7))
         (copy (copy-sequence source))
         (slice (substring source 1 3)))
    (should (equal-including-properties source copy))
    (should (eq (get-text-property 0 'face slice) 'bold))
    (with-temp-buffer
      (let ((yank-excluded-properties '(secret)))
        (insert-for-yank source))
      (should (eq (get-text-property 1 'face) 'bold))
      (should-not (get-text-property 1 'secret))
      (should (eq (get-text-property
                   0 'face (buffer-substring 1 3))
                  'bold))
      (should-not (text-properties-at
                   0 (buffer-substring-no-properties 1 3))))))

(ert-deftest tp-native-test-narrowing-and-indirect-buffer-coordinates ()
  "Public operations keep native positions across narrowing and indirection."
  (let ((base (generate-new-buffer " *tp-native-base*"))
        indirect)
    (unwind-protect
        (progn
          (with-current-buffer base
            (insert "abcdef")
            (setq indirect
                  (make-indirect-buffer base " *tp-native-indirect*" t)))
          (with-current-buffer indirect
            (narrow-to-region 2 5)
            (should (equal (tp-set 2 4 '(state shared)) '(2 . 4)))
            (let ((result (tp-lookup 3 'state :mode :text-direct)))
              (should (eq (tp-lookup-result-object result) indirect))
              (should (= (tp-lookup-result-position result) 3))
              (should (eq (tp-lookup-result-value result) 'shared))))
          (with-current-buffer base
            (should (eq (get-text-property 3 'state) 'shared))))
      (when (buffer-live-p indirect) (kill-buffer indirect))
      (when (buffer-live-p base) (kill-buffer base)))))

(ert-deftest tp-native-test-emacs-28-required-primitives-exist ()
  "The selected native mapping stays within the Emacs 28.1 baseline."
  (dolist (function '(object-intervals
                      text-property-search-forward
                      text-property-search-backward
                      make-prop-match
                      with-silent-modifications
                      overlays-at
                      get-char-property
                      get-char-property-and-overlay
                      text-property-any
                      text-property-not-all
                      previous-single-property-change
                      previous-property-change))
    (should (fboundp function))))

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