;;; tp-core-tests.el --- ERT tests for tp-core.el -*- lexical-binding: t -*-

;;; Commentary:

;; Unit tests for the tp-core foundation module.

;;; Code:

(require 'ert)
(require 'tp-core)

;;; tp--map-intervals

(ert-deftest tp-core-test-map-intervals-string-clips ()
  "Intervals extending beyond the range are clipped to it."
  (let ((str (copy-sequence "hello world")))
    (put-text-property 0 11 'face 'bold str)
    (should (equal (tp--map-intervals str 3 7 #'list)
                   '((3 7 (face bold)))))))

(ert-deftest tp-core-test-map-intervals-string-full ()
  "Full-range walk over a string returns each property run."
  (let ((str (copy-sequence "hello world")))
    (put-text-property 0 5 'face 'bold str)
    (should (equal (tp--map-intervals str nil nil #'list)
                   '((0 5 (face bold)) (5 11 nil))))))

(ert-deftest tp-core-test-map-intervals-single-property ()
  "PROPERTY narrows runs to that property and passes its value."
  (let ((str (copy-sequence "hello world")))
    (put-text-property 0 5 'face 'bold str)
    (put-text-property 2 8 'help-echo "tip" str)
    (should (equal (tp--map-intervals str nil nil #'list 'face)
                   '((0 5 bold) (5 11 nil))))))

(ert-deftest tp-core-test-map-intervals-buffer-clips ()
  "Buffer walk clips to the requested range with 1-based positions."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 1 12 'face 'bold)
    (should (equal (tp--map-intervals nil 4 8 #'list)
                   '((4 8 (face bold)))))))

(ert-deftest tp-core-test-map-intervals-buffer-multiple-runs ()
  "Multiple runs in a buffer are visited in order, gaps included."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 1 6 'face 'bold)
    (put-text-property 7 12 'face 'italic)
    (should (equal (tp--map-intervals nil nil nil #'list 'face)
                   '((1 6 bold) (6 7 nil) (7 12 italic))))))

(ert-deftest tp-core-test-map-intervals-out-of-range-normalized ()
  "Out-of-bounds START/END are clamped, not signaled."
  (let ((str (copy-sequence "abc")))
    (put-text-property 0 3 'p 1 str)
    (should (equal (tp--map-intervals str -5 99 #'list 'p)
                   '((0 3 1))))))

(ert-deftest tp-core-test-map-intervals-empty-range ()
  "An empty range visits nothing."
  (let ((str (copy-sequence "abc")))
    (should (equal (tp--map-intervals str 1 1 #'list) nil))))

;;; tp-face-properties

(ert-deftest tp-core-test-face-properties ()
  "The face-family property list contains the three face properties."
  (should (equal tp-face-properties '(face font-lock-face mouse-face))))

;;; Stage 2 canonical façade

(ert-deftest tp-core-test-native-range-string-and-buffer-coordinates ()
  "Canonical ranges store concrete objects and native coordinates."
  (let* ((str (copy-sequence "abcd"))
         (range (tp--native-range-from-object str 1 3)))
    (should (tp--native-range-p range))
    (should (eq (tp--native-range-kind range) :string))
    (should (eq (tp--native-range-object range) str))
    (should (equal (list (tp--native-range-start range)
                         (tp--native-range-end range))
                   '(1 3))))
  (with-temp-buffer
    (insert "abcd")
    (narrow-to-region 2 4)
    (let ((range (tp--native-range-from-object nil nil nil)))
      (should (eq (tp--native-range-kind range) :buffer))
      (should (eq (tp--native-range-object range) (current-buffer)))
      (should (equal (list (tp--native-range-start range)
                           (tp--native-range-end range))
                     '(2 4))))))

(ert-deftest tp-core-test-presence-distinguishes-three-value-states ()
  "Canonical presence 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--presence-at 0 'state str))
          (value (tp--presence-at 1 'state str))
          (absent (tp--presence-at 2 'state str)))
      (should (tp--presence-present-p nil-value))
      (should-not (tp--presence-value nil-value))
      (should (tp--presence-present-p value))
      (should (eq (tp--presence-value value) 'ready))
      (should-not (tp--presence-present-p absent))
      (should-not (tp--presence-value absent)))))

(ert-deftest tp-core-test-canonical-request-match-and-result-adapters ()
  "Canonical records preserve policy and adapt only at public boundaries."
  (let* ((str (copy-sequence "abcd"))
         (range (tp--native-range-from-object str 1 3))
         (request (tp--make-request
                   :operation :set :range range :props '(face bold)
                   :mutation :copy :read-only :respect
                   :noerror nil :public-return :range))
         (match (tp--make-match range 'face 'bold))
         (result (tp--make-result
                  :request request :matches (list match)
                  :count 1 :object str :native 'native-value)))
    (should (tp--request-p request))
    (should (eq (tp--request-operation request) :set))
    (should (eq (tp--request-mutation request) :copy))
    (should (equal (tp--match-to-list match) '(1 3 bold)))
    (let ((native-match (tp--match-to-prop-match match)))
      (should (= (prop-match-beginning native-match) 1))
      (should (= (prop-match-end native-match) 3))
      (should (eq (prop-match-value native-match) 'bold)))
    (should (equal (tp--result-public-value result) '(1 . 3)))
    (setf (tp--request-public-return request) :matches)
    (should (equal (tp--result-public-value result) '((1 3 bold))))
    (setf (tp--request-public-return request) :count)
    (should (= (tp--result-public-value result) 1))
    (setf (tp--request-public-return request) :native)
    (should (eq (tp--result-public-value result) 'native-value))))

(ert-deftest tp-core-test-property-value-copy-has-explicit-identity-rules ()
  "Property copies own data containers and preserve opaque identities."
  (with-temp-buffer
    (let* ((caller-string (copy-sequence "value"))
           (caller-vector (vector (copy-sequence "nested")))
           (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)))
           (value (list caller-string caller-vector record callback table
                        marker (current-buffer)))
           (copy (tp--copy-property-value value)))
      (should-not (eq copy value))
      (should-not (eq (nth 0 copy) caller-string))
      (should-not (eq (nth 1 copy) caller-vector))
      (should-not (eq (aref (nth 1 copy) 0) (aref caller-vector 0)))
      (should (eq (nth 2 copy) record))
      (should (eq (nth 3 copy) callback))
      (should (eq (nth 4 copy) table))
      (should (eq (nth 5 copy) marker))
      (should (eq (nth 6 copy) (current-buffer)))
      (should (= calls 0))
      (aset caller-string 0 ?V)
      (aset (aref caller-vector 0) 0 ?N)
      (should (equal (nth 0 copy) "value"))
      (should (equal (nth 1 copy) ["nested"])))))

(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
  "Full keymaps, parent maps and self-references retain an isolated graph."
  (let* ((map (make-keymap))
         (parent (make-keymap))
         (callback (lambda () "callback")))
    (define-key map (kbd "RET") callback)
    (define-key parent (kbd "x") #'ignore)
    (define-key map [prefix] map)
    (set-keymap-parent map parent)
    (let ((copy (tp-property-value-copy map)))
      (should-not (eq copy map))
      (should-not (eq (keymap-parent copy) parent))
      (should (eq (lookup-key copy [prefix]) copy))
      (should (eq (lookup-key copy (kbd "RET")) callback))
      (define-key map (kbd "RET") #'forward-char)
      (define-key parent (kbd "x") #'backward-char)
      (should (eq (lookup-key copy (kbd "RET")) callback))
      (should (eq (lookup-key copy (kbd "x")) #'ignore)))))

(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
  "Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
  (let ((purpose (make-symbol "tp-copy-table")))
    (put purpose 'char-table-extra-slots 1)
    (let* ((parent (make-char-table purpose))
           (table (make-char-table purpose))
           (value (list 'value)))
      (set-char-table-range parent ?p value)
      (set-char-table-range table ?x value)
      (set-char-table-range table ?s table)
      (set-char-table-extra-slot table 0 value)
      (set-char-table-parent table parent)
      (let ((copy (tp-property-value-copy table)))
        (should (eq (char-table-range copy ?s) copy))
        (should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
        (should (eq (char-table-range copy ?x)
                    (char-table-range (char-table-parent copy) ?p)))
        (set-char-table-range (char-table-parent copy) ?p 'new)
        (should (eq (char-table-range copy ?p) 'new))
        (set-char-table-range copy nil 'default)
        (should (eq (char-table-range copy ?z) 'default))
        (setcar value 'mutated)
        (should (equal (char-table-range copy ?x) '(value)))))))

(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
  "Property copies keep list-shaped function values opaque."
  (let ((function-value '(lambda () 1)))
    (should (functionp function-value))
    (should (eq (tp--copy-property-value function-value)
                function-value))))

(ert-deftest tp-core-test-property-value-copy-deep-copies-string-properties ()
  "Property copies do not alias mutable values stored in string properties."
  (let* ((owners (list 'original))
         (text (copy-sequence "x")))
    (add-text-properties 0 1 (list 'ebox-content-owners owners) text)
    (let ((copy (tp--copy-property-value text)))
      (should-not (eq copy text))
      (should-not (eq (get-text-property 0 'ebox-content-owners copy)
                      owners))
      (setcar owners 'caller-mutated)
      (should (equal (get-text-property 0 'ebox-content-owners copy)
                     '(original)))
      (setcar (get-text-property 0 'ebox-content-owners copy) 'copy-mutated)
      (should (equal (get-text-property 0 'ebox-content-owners text)
                     '(caller-mutated))))))

(ert-deftest tp-core-test-property-value-copy-preserves-source-identity-rules ()
  "Property copies memoize one source identity without canonicalizing equals."
  (let* ((shared (list 'shared))
         (equal-but-distinct (list 'shared))
         (value (list shared shared equal-but-distinct))
         (copy (tp--copy-property-value value)))
    (should (eq (nth 0 copy) (nth 1 copy)))
    (should-not (eq (nth 0 copy) (nth 2 copy)))
    (should-not (eq (nth 0 copy) shared))
    (should-not (eq (nth 2 copy) equal-but-distinct))
    (setcar shared 'source-mutated)
    (should (equal (nth 0 copy) '(shared)))
    (setcar (nth 0 copy) 'copy-mutated)
    (should (equal shared '(source-mutated)))
    (should (equal equal-but-distinct '(shared)))))

(ert-deftest tp-core-test-property-value-copy-reuses-string-identity ()
  "Property copies preserve repeated references to one propertized string."
  (let* ((shared (copy-sequence "shared"))
         (value (list shared shared))
         (copy (tp--copy-property-value value)))
    (should (eq (nth 0 copy) (nth 1 copy)))
    (should-not (eq (nth 0 copy) shared))))

(ert-deftest tp-core-test-text-snapshot-transfers-authorized-values ()
  "Text snapshots transfer only values explicitly owned by the caller."
  (let* ((owned (list :face t))
         (copied (list :face t))
         (text (copy-sequence "ab")))
    (put-text-property 0 1 'face owned text)
    (put-text-property 1 2 'payload copied text)
    (let ((snapshot
           (tp-text-snapshot
            text (lambda (property value)
                   (and (eq property 'face) (eq value owned))))))
      (should (eq (get-text-property 0 'face snapshot) owned))
      (should-not (eq (get-text-property 1 'payload snapshot) copied))
      (should-not (eq (get-text-property 1 'payload snapshot) owned)))))

(ert-deftest tp-core-test-text-snapshot-transfer-does-not-pollute-copy-cache ()
  "Transferred values do not make an unauthorized property alias its source."
  (let* ((shared (list :face t))
         (text (copy-sequence "ab")))
    (put-text-property 0 1 'face shared text)
    (put-text-property 1 2 'payload shared text)
    (let ((snapshot
           (tp-text-snapshot
            text (lambda (property _value) (eq property 'face)))))
      (should (eq (get-text-property 0 'face snapshot) shared))
      (should-not (eq (get-text-property 1 'payload snapshot) shared))
      (should-not (eq (get-text-property 1 'payload snapshot)
                      (get-text-property 0 'face snapshot))))))

(ert-deftest tp-core-test-text-snapshot-copies-propertized-strings-by-default ()
  "Text snapshots preserve nested string properties under strict copying."
  (let* ((first (propertize "x" 'nested 'first))
         (second (propertize "x" 'nested 'second))
         (text (copy-sequence "ab")))
    (put-text-property 0 1 'payload first text)
    (put-text-property 1 2 'payload second text)
    (let ((snapshot (tp-text-snapshot text)))
      (should-not (eq (get-text-property 0 'payload snapshot)
                      (get-text-property 1 'payload snapshot)))
      (should (eq (get-text-property 0 'nested
                                     (get-text-property 0 'payload snapshot))
                  'first))
      (should (eq (get-text-property 0 'nested
                                     (get-text-property 1 'payload snapshot))
                  'second)))))

(ert-deftest tp-core-test-text-snapshot-copies-circular-values-by-default ()
  "Text snapshots copy circular values without invoking equality."
  (let* ((first (cons :cycle nil))
         (second (cons :cycle nil))
         (text (copy-sequence "ab")))
    (setcdr first first)
    (setcdr second second)
    (put-text-property 0 1 'payload first text)
    (put-text-property 1 2 'payload second text)
    (let ((snapshot (tp-text-snapshot text)))
      (should-not (eq (get-text-property 0 'payload snapshot)
                      (get-text-property 1 'payload snapshot)))
      (should (eq (cdr (get-text-property 0 'payload snapshot))
                  (get-text-property 0 'payload snapshot)))
      (should (eq (cdr (get-text-property 1 'payload snapshot))
                  (get-text-property 1 'payload snapshot))))))

(ert-deftest tp-core-test-property-value-copy-preserves-flat-list-sharing ()
  "Flat-list snapshots memoize every cons cell, including shared tails."
  (let* ((tail (list :tail))
         (value (list (cons :head tail) tail))
         (copy (tp--copy-property-value value)))
    (should (eq (cdr (car copy)) (cadr copy)))
    (should-not (eq (cadr copy) tail))))

(ert-deftest tp-core-test-property-value-copy-terminates-on-circular-list ()
  "Circular list snapshots use the recursive memo path without looping."
  (let ((value (cons :cycle nil)))
    (setcdr value value)
    (let ((copy (tp--copy-property-value value)))
      (should-not (eq copy value))
      (should (eq (cdr copy) copy)))))

(ert-deftest tp-core-test-public-property-value-copy-is-defensive ()
  "The public copy boundary preserves opaque values and isolates containers."
  (let* ((function (lambda () t))
         (source (list :nested (vector "value") :function function))
         (copy (tp-property-value-copy source)))
    (should (equal copy source))
    (should-not (eq copy source))
    (should-not (eq (plist-get copy :nested)
                    (plist-get source :nested)))
    (should (eq (plist-get copy :function) function))))

;;; API-COORD-01: ABSOLUTE coordinates in tp-intervals / tp-intervals-map

(ert-deftest tp-core-test-intervals-buffer-relative-default ()
  "Without ABSOLUTE, buffer intervals stay START-relative (legacy)."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 4 8 'face 'bold)
    (should (equal (tp-intervals 3 9)
                   '((0 1 nil) (1 5 (face bold)) (5 6 nil))))))

(ert-deftest tp-core-test-intervals-buffer-absolute ()
  "With ABSOLUTE, buffer intervals use native 1-based positions."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 4 8 'face 'bold)
    (should (equal (tp-intervals 3 9 nil t)
                   '((3 4 nil) (4 8 (face bold)) (8 9 nil))))
    ;; Clipping still applies in native coordinates.
    (should (equal (tp-intervals 5 7 nil t)
                   '((5 7 (face bold)))))))

(ert-deftest tp-core-test-intervals-string-ignores-absolute ()
  "String intervals are already absolute; ABSOLUTE changes nothing."
  (let ((s (copy-sequence "hello world")))
    (put-text-property 3 7 'face 'bold s)
    (should (equal (tp-intervals 2 9 s) (tp-intervals 2 9 s t)))
    (should (equal (tp-intervals 2 9 s t)
                   '((2 3 nil) (3 7 (face bold)) (7 9 nil))))))

(ert-deftest tp-core-test-intervals-map-absolute ()
  "tp-intervals-map passes ABSOLUTE through to native positions."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 4 8 'face 'bold)
    (should (equal (tp-intervals-map #'list 3 9)
                   '((0 1 nil nil) (1 5 (face bold) nil) (5 6 nil nil))))
    (should (equal (tp-intervals-map #'list 3 9 nil t)
                   '((3 4 nil nil) (4 8 (face bold) nil) (8 9 nil nil))))))

(ert-deftest tp-core-test-intervals-map-returns-direct-properties ()
  "tp-intervals-map returns direct properties and a nil reserved slot."
  (with-temp-buffer
    (insert "hello")
    (set-text-properties 1 6 '(face bold help-echo "direct"))
    (let ((res (tp-intervals-map #'list 1 6 nil t)))
      (should (= (length res) 1))
      (pcase-let ((`(,beg ,end ,props ,reserved) (car res)))
        (should (= beg 1))
        (should (= end 6))
        (should (eq (plist-get props 'face) 'bold))
        (should (equal (plist-get props 'help-echo) "direct"))
        (should-not reserved)))))

(ert-deftest tp-core-test-intervals-map-drops-nil-results ()
  "nil results from FUNCTION are removed from the returned list."
  (with-temp-buffer
    (insert "hello world")
    (put-text-property 4 8 'face 'bold)
    (should (equal (tp-intervals-map
                    (lambda (beg end top _below)
                      (when (plist-get top 'face) (cons beg end)))
                    1 12 nil t)
                   '((4 . 8))))))

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