367 lines
16 KiB
EmacsLisp
367 lines
16 KiB
EmacsLisp
;;; 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-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
|