ceb0dfb0bc
35 fixes across tp-layer.el, tp-stack.el, tp-search.el, tp-reactive.el and tp-render.el, each empirically reproduced before and after: layer-definition resolution/cycles/copying/cleanup, clipped region-local stack mutators, symmetric backward search matching, length-changing replacements, and reactive re-render correctness (replace-not-accumulate, buffer-local isolation, batching union, per-interval props). Adds four per-module regression suites (100 new tests); combined suite is 438/438 green. tp-test-backward updated to the now-symmetric backward matching contract it previously codified inverted. The string-vs-buffer shortfall divergence in tp-forward-do/tp-backward-do is documented in CHANGELOG as a known divergence rather than changed. Adds CHANGELOG.md. Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
384 lines
15 KiB
EmacsLisp
384 lines
15 KiB
EmacsLisp
;;; tp-stack-tests.el --- ERT regression tests for tp-stack.el -*- lexical-binding: t -*-
|
|
|
|
;;; Commentary:
|
|
|
|
;; Regression tests for confirmed bugs fixed in the layer-stack module
|
|
;; (tp-stack.el). Each section is tagged with the canonical bug id it
|
|
;; guards against.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp)
|
|
|
|
(defmacro tp-stack-tests--with-env (&rest body)
|
|
"Run BODY in a temp buffer with a clean tp layer state.
|
|
Layer registries are reset before BODY and again afterwards so
|
|
definitions cannot leak between tests."
|
|
(declare (indent 0))
|
|
`(unwind-protect
|
|
(with-temp-buffer
|
|
(tp-layer-reset)
|
|
,@body)
|
|
(tp-layer-reset)))
|
|
|
|
(defun tp-stack-tests--has-prop-p (pos prop &optional object)
|
|
"Return non-nil if PROP is present (even with value nil) at POS of OBJECT."
|
|
(and (plist-member (text-properties-at pos object) prop) t))
|
|
|
|
;;; B28: region ops must not mutate text outside [START, END)
|
|
|
|
(ert-deftest tp-stack-test-delete-layer-subregion-keeps-outside ()
|
|
"Deleting a layer on a sub-region leaves the rest of the stack alone."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdefghij")
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer 1 11 'layer1)
|
|
(tp-push-layer 1 11 'layer2)
|
|
(tp-delete-layer 3 6 'layer2)
|
|
;; Inside [3, 6): layer2 gone, layer1 now on top.
|
|
(should (eq (get-text-property 3 'tp-name) 'layer1))
|
|
(should (eq (get-text-property 5 'tp-name) 'layer1))
|
|
(should-not (tp-layer-exists-p 3 6 'layer2))
|
|
;; Outside the region: the full 2-layer stack survives.
|
|
(should (eq (get-text-property 1 'tp-name) 'layer2))
|
|
(should (eq (get-text-property 2 'tp-name) 'layer2))
|
|
(should (eq (get-text-property 6 'tp-name) 'layer2))
|
|
(should (eq (get-text-property 10 'tp-name) 'layer2))
|
|
(should (tp-layer-exists-p 1 3 'layer1))
|
|
(should (tp-layer-exists-p 6 11 'layer1))))
|
|
|
|
(ert-deftest tp-stack-test-push-layer-subregion-keeps-outside ()
|
|
"Pushing onto a sub-region does not smear over the whole interval."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdefghij")
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer 1 4 'layer1)
|
|
(tp-push-layer 3 8 'layer2)
|
|
;; [1, 3): still only layer1.
|
|
(should (eq (get-text-property 1 'tp-name) 'layer1))
|
|
(should (eq (get-text-property 2 'tp-name) 'layer1))
|
|
(should-not (tp-layer-exists-p 1 3 'layer2))
|
|
;; [3, 4): layer2 stacked over layer1.
|
|
(should (eq (get-text-property 3 'tp-name) 'layer2))
|
|
(should (tp-layer-exists-p 3 4 'layer1))
|
|
;; [4, 8): only layer2.
|
|
(should (eq (get-text-property 5 'tp-name) 'layer2))
|
|
(should-not (tp-layer-exists-p 4 8 'layer1))
|
|
;; [8, 11): untouched bare text.
|
|
(should (null (text-properties-at 8)))
|
|
(should (null (text-properties-at 10)))))
|
|
|
|
(ert-deftest tp-stack-test-push-layer-subregion-string ()
|
|
"Region-form push on a string only affects the requested sub-range."
|
|
(tp-stack-tests--with-env
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-put-layer 2 5 'layer1 0 str)
|
|
(should (null (text-properties-at 0 str)))
|
|
(should (null (text-properties-at 1 str)))
|
|
(should (eq (get-text-property 2 'tp-name str) 'layer1))
|
|
(should (eq (get-text-property 4 'tp-name str) 'layer1))
|
|
(should (null (text-properties-at 5 str))))))
|
|
|
|
;;; B29: tp-put-layer must be region-local, not whole-object
|
|
|
|
(ert-deftest tp-stack-test-put-layer-bare-region-distant-props ()
|
|
"Putting a layer on a bare region ignores properties elsewhere."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdefghij")
|
|
(define-tp layer1 () '(face bold))
|
|
(put-text-property 8 10 'help-echo "far")
|
|
(tp-push-layer 1 4 'layer1)
|
|
;; The layer covers exactly [1, 4).
|
|
(should (eq (get-text-property 1 'tp-name) 'layer1))
|
|
(should (eq (get-text-property 3 'tp-name) 'layer1))
|
|
(should (null (text-properties-at 4)))
|
|
(should (null (text-properties-at 7)))
|
|
;; The distant properties are untouched.
|
|
(should (equal (get-text-property 8 'help-echo) "far"))
|
|
(should (null (get-text-property 8 'tp-name)))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-same-result-with-or-without-distant-props ()
|
|
"Distant unrelated properties do not change what put-layer writes."
|
|
(tp-stack-tests--with-env
|
|
(define-tp layer1 () '(face bold))
|
|
(let (props-bare props-distant)
|
|
(with-temp-buffer
|
|
(insert "abcdefghij")
|
|
(tp-push-layer 1 4 'layer1)
|
|
(setq props-bare (text-properties-at 1)))
|
|
(with-temp-buffer
|
|
(insert "abcdefghij")
|
|
(put-text-property 8 10 'help-echo "far")
|
|
(tp-push-layer 1 4 'layer1)
|
|
(setq props-distant (text-properties-at 1)))
|
|
(should (equal props-bare props-distant)))))
|
|
|
|
;;; B30: inline plists with ordinary (non-keyword) properties
|
|
|
|
(ert-deftest tp-stack-test-put-layer-inline-plist-plain ()
|
|
"An inline plist like (face bold) is a valid layer spec."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(tp-put-layer 1 6 '(face bold) 0)
|
|
(should (eq (get-text-property 1 'face) 'bold))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-inline-plist-nested ()
|
|
"An inline plist with a nested value list is a valid layer spec."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(tp-put-layer 1 6 '(face (:foreground "red")) 0)
|
|
(should (equal (get-text-property 1 'face) '(:foreground "red")))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-inline-plist-multi-pair ()
|
|
"A multi-pair inline plist is applied as one layer."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(tp-put-layer 1 6 '(face bold help-echo "tip") 0)
|
|
(should (eq (get-text-property 1 'face) 'bold))
|
|
(should (equal (get-text-property 1 'help-echo) "tip"))
|
|
(should (= (tp-layer-count 1 6) 1))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-named-inline-still-works ()
|
|
"A named inline layer (NAME PROP VAL ...) keeps its old meaning."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(tp-put-layer 1 6 '(mylayer face bold) 0)
|
|
(should (eq (get-text-property 1 'tp-name) 'mylayer))
|
|
(should (eq (get-text-property 1 'face) 'bold))))
|
|
|
|
;;; B31: list of layer names
|
|
|
|
(ert-deftest tp-stack-test-put-layer-list-of-names ()
|
|
"A list of defined layer names pushes each as its own layer."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer-a () '(face bold))
|
|
(define-tp layer-b () '(help-echo "b"))
|
|
(tp-put-layer 1 5 '(layer-a layer-b) 0)
|
|
(should (= (tp-layer-count 1 5) 2))
|
|
(should (eq (tp-layer-top 1 5) 'layer-a))
|
|
(should (tp-layer-exists-p 1 5 'layer-a))
|
|
(should (tp-layer-exists-p 1 5 'layer-b))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-mixed-list ()
|
|
"A list mixing a layer name and an inline plist works."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer-a () '(face bold))
|
|
(tp-put-layer 1 5 '(layer-a (help-echo "inline")) 0)
|
|
(should (= (tp-layer-count 1 5) 2))
|
|
(should (eq (tp-layer-top 1 5) 'layer-a))))
|
|
|
|
;;; B32: parameterized groups
|
|
|
|
(ert-deftest tp-stack-test-put-layer-parameterized-group ()
|
|
"A (GROUP-NAME ARG) spec resolves a parameterized group."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp pcolor (c) `(face (:foreground ,c)))
|
|
(define-tps pgroup (c) `(pcolor ,c))
|
|
(tp-put-layer 1 6 '(pgroup "red") 0)
|
|
(should (equal (get-text-property 1 'face) '(:foreground "red")))
|
|
(should (eq (get-text-property 1 'tp-name) 'pcolor))))
|
|
|
|
(ert-deftest tp-stack-test-put-layer-parameterized-group-without-arg-errors ()
|
|
"A bare parameterized group name signals instead of silently no-oping."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp pcolor (c) `(face (:foreground ,c)))
|
|
(define-tps pgroup (c) `(pcolor ,c))
|
|
(should-error (tp-put-layer 1 6 'pgroup 0))))
|
|
|
|
;;; B33: tp-region-layer-props string positions
|
|
|
|
(ert-deftest tp-stack-test-region-layer-props-string-subrange ()
|
|
"String sub-range queries return absolute in-bounds string positions."
|
|
(tp-stack-tests--with-env
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-push-layer str 'layer1)
|
|
(let ((result (tp-region-layer-props 2 5 'layer1 str)))
|
|
(should (= (length result) 1))
|
|
(should (= (nth 0 (car result)) 2))
|
|
(should (= (nth 1 (car result)) 5))
|
|
(should (<= (nth 1 (car result)) (length str)))
|
|
(should (eq (plist-get (nth 2 (car result)) 'tp-name) 'layer1))))))
|
|
|
|
(ert-deftest tp-stack-test-region-layer-props-buffer-subrange ()
|
|
"Buffer queries return 1-based positions clipped to the region."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-push-layer 1 7 'layer1)
|
|
(let ((result (tp-region-layer-props 2 4 'layer1)))
|
|
(should (equal (list (nth 0 (car result)) (nth 1 (car result)))
|
|
'(2 4))))))
|
|
|
|
;;; string/buffer path convergence for region-form mutators
|
|
|
|
(ert-deftest tp-stack-test-delete-layer-string-region-form ()
|
|
"Region-form delete on a string works and stays inside the range."
|
|
(tp-stack-tests--with-env
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer str 'layer1)
|
|
(tp-push-layer str 'layer2)
|
|
(tp-delete-layer 2 5 'layer2 str)
|
|
(should (eq (get-text-property 2 'tp-name str) 'layer1))
|
|
(should (eq (get-text-property 4 'tp-name str) 'layer1))
|
|
;; Outside [2, 5) both layers survive.
|
|
(should (eq (get-text-property 0 'tp-name str) 'layer2))
|
|
(should (eq (get-text-property 5 'tp-name str) 'layer2))
|
|
(should (tp-layer-exists-p 0 2 'layer1 str))
|
|
(should (tp-layer-exists-p 5 6 'layer1 str)))))
|
|
|
|
;;; B34: explicit nil values survive merge/flatten precedence
|
|
|
|
(ert-deftest tp-stack-test-merge-layers-explicit-nil-wins ()
|
|
"An explicitly-nil value in a higher-precedence layer is kept."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp lower () '(face bold))
|
|
(define-tp upper () '(face nil help-echo "u"))
|
|
(tp-push-layer 1 6 'lower)
|
|
(tp-push-layer 1 6 'upper)
|
|
(tp-merge-layers 1 6 'merged '(upper lower))
|
|
(should (tp-stack-tests--has-prop-p 1 'face))
|
|
(should (null (get-text-property 1 'face)))
|
|
(should (equal (get-text-property 1 'help-echo) "u"))
|
|
(should (eq (get-text-property 1 'tp-name) 'merged))))
|
|
|
|
(ert-deftest tp-stack-test-flatten-layers-explicit-nil-wins ()
|
|
"Flattening keeps an explicit nil from a higher layer over lower values."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp lower () '(face bold help-echo "low"))
|
|
(define-tp upper () '(face nil))
|
|
(tp-push-layer 1 6 'lower)
|
|
(tp-push-layer 1 6 'upper)
|
|
(tp-flatten-layers 1 6 'flat)
|
|
(should (tp-stack-tests--has-prop-p 1 'face))
|
|
(should (null (get-text-property 1 'face)))
|
|
(should (equal (get-text-property 1 'help-echo) "low"))
|
|
(should (eq (get-text-property 1 'tp-name) 'flat))))
|
|
|
|
;;; B35: no garbage (tp-layers nil) on single-layer stacks
|
|
|
|
(ert-deftest tp-stack-test-single-layer-no-tp-layers-prop ()
|
|
"Pushing one layer does not leave a (tp-layers nil) property behind."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-push-layer 1 6 'layer1)
|
|
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
|
|
(should (eq (get-text-property 1 'face) 'bold))))
|
|
|
|
(ert-deftest tp-stack-test-delete-to-single-layer-no-tp-layers-prop ()
|
|
"Deleting down to one layer drops the tp-layers property entirely."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer 1 6 'layer1)
|
|
(tp-push-layer 1 6 'layer2)
|
|
;; With two layers the below-stack is a real, non-nil list.
|
|
(should (get-text-property 1 'tp-layers))
|
|
(tp-delete-layer 1 6 'layer2)
|
|
(should-not (tp-stack-tests--has-prop-p 1 'tp-layers))
|
|
(should (eq (get-text-property 1 'tp-name) 'layer1))))
|
|
|
|
(ert-deftest tp-stack-test-pop-to-single-layer-no-tp-layers-prop ()
|
|
"Popping down to one layer drops the tp-layers property entirely."
|
|
(tp-stack-tests--with-env
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer str 'layer1)
|
|
(tp-push-layer str 'layer2)
|
|
(tp-pop-layer str)
|
|
(should-not (plist-member (text-properties-at 0 str) 'tp-layers))
|
|
(should (eq (get-text-property 0 'tp-name str) 'layer1)))))
|
|
|
|
(ert-deftest tp-stack-test-absent-tp-layers-tolerated-by-stack-ops ()
|
|
"Stacks without a tp-layers property still work with every operation."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(tp-push-layer 1 6 'layer1) ; single layer, no tp-layers prop
|
|
(should (= (tp-layer-count 1 6) 1))
|
|
(should (equal (tp-layer-list 1 6) '(layer1)))
|
|
(should (tp-layer-exists-p 1 6 'layer1))
|
|
(should (eq (tp-layer-top 1 6) 'layer1))
|
|
(tp-push-layer 1 6 'layer2) ; stacking on top still works
|
|
(should (= (tp-layer-count 1 6) 2))
|
|
(should (eq (tp-layer-top 1 6) 'layer2))
|
|
(should (tp-layer-exists-p 1 6 'layer1))))
|
|
|
|
;;; B36: tp-layer-top respects the whole region
|
|
|
|
(ert-deftest tp-stack-test-layer-top-mid-region-layer ()
|
|
"A layer starting after bare text is still found by tp-layer-top."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-push-layer 3 6 'layer1)
|
|
(should (eq (tp-layer-top 1 6) 'layer1))))
|
|
|
|
(ert-deftest tp-stack-test-layer-top-respects-end ()
|
|
"tp-layer-top does not report layers that lie beyond END."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer1 () '(face bold))
|
|
(tp-push-layer 4 6 'layer1)
|
|
(should (null (tp-layer-top 1 3)))))
|
|
|
|
(ert-deftest tp-stack-test-layer-top-first-named-run-wins ()
|
|
"The first run with a named top layer determines the result."
|
|
(tp-stack-tests--with-env
|
|
(insert "abcdef")
|
|
(define-tp layer-a () '(face bold))
|
|
(define-tp layer-b () '(face italic))
|
|
(tp-push-layer 1 3 'layer-a)
|
|
(tp-push-layer 3 6 'layer-b)
|
|
(should (eq (tp-layer-top 1 6) 'layer-a))
|
|
(should (eq (tp-layer-top 3 6) 'layer-b))))
|
|
|
|
;;; Shared argument normalizer: both calling conventions still work
|
|
|
|
(ert-deftest tp-stack-test-normalizer-string-forms ()
|
|
"Whole-string forms of the routed mutators behave as before."
|
|
(tp-stack-tests--with-env
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(define-tp layer1 () '(face bold))
|
|
(define-tp layer2 () '(face italic))
|
|
(define-tp layer3 () '(face underline))
|
|
(tp-push-layer str 'layer1)
|
|
(tp-push-layer str 'layer2)
|
|
(tp-push-layer str 'layer3)
|
|
(should (eq (tp-layer-top 0 6 str) 'layer3))
|
|
(tp-rotate-layer str)
|
|
(should (eq (tp-layer-top 0 6 str) 'layer2))
|
|
(tp-pin-layer str 'layer1)
|
|
(should (eq (tp-layer-top 0 6 str) 'layer1))
|
|
(tp-pop-layer str)
|
|
(should (eq (tp-layer-top 0 6 str) 'layer2))
|
|
(tp-delete-layer str 'layer3)
|
|
(should (equal (tp-layer-list 0 6 str) '(layer2)))
|
|
(should (eq (tp-push-layer str 'layer1) str)))))
|
|
|
|
(ert-deftest tp-stack-test-normalizer-invalid-first-arg-signals ()
|
|
"A non-string, non-number first argument signals a clear error."
|
|
(tp-stack-tests--with-env
|
|
(define-tp layer1 () '(face bold))
|
|
(should-error (tp-push-layer nil 'layer1))
|
|
(should-error (tp-delete-layer 'not-a-position 5 'layer1))))
|
|
|
|
(provide 'tp-stack-tests)
|
|
;;; tp-stack-tests.el ends here
|