0d35358e05
Replace the legacy managed layer renderer with one independent retained/reactive text runtime. TP now owns exact dependencies, stable objects, marker-backed mounts, property contribution composition, atomic publication, rollback, and direct text-property facades without ECSS or Ebox dependencies.\n\nBREAKING CHANGE: remove tp-render, tp-stack, scan-driven managed layers, inline runtime metadata, TP-owned CSS cascade APIs, and dollar-variable declarations.\n\nVerified: 290/290 ERT, shuffled 290/290 (seed 20260806), 8/8 doctests, WERROR compile-all, checkdoc, package-lint, diff-check, and isolated TP-only load.
297 lines
13 KiB
EmacsLisp
297 lines
13 KiB
EmacsLisp
;;; tp-layer-tests.el --- Declaration recipe tests -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Contract tests for static and parameterized named declaration recipes.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp)
|
|
|
|
(defmacro tp-layer-test--isolated (&rest body)
|
|
"Run BODY with isolated declaration recipe registries."
|
|
(declare (indent 0) (debug t))
|
|
`(unwind-protect
|
|
(progn (tp-layer-reset) ,@body)
|
|
(tp-layer-reset)))
|
|
|
|
(ert-deftest tp-layer-test-static-recipe-expands-to-direct-properties ()
|
|
"A static recipe expands without runtime metadata."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-static ()
|
|
'(face bold help-echo "static"))
|
|
(should (equal (tp-layer-props 'tp-layer-test-static)
|
|
'(face bold help-echo "static")))
|
|
(let ((text (tp-set "demo" 'tp-layer-test-static)))
|
|
(should (eq (get-text-property 0 'face text) 'bold))
|
|
(should (equal (get-text-property 0 'help-echo text) "static")))))
|
|
|
|
(ert-deftest tp-layer-test-parameterized-recipe-requires-exact-arity ()
|
|
"Parameterized recipes bind every declared argument exactly once."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-parameterized (foreground weight)
|
|
`(face (:foreground ,foreground :weight ,weight)))
|
|
(should
|
|
(equal (tp-layer-props-with-args
|
|
'tp-layer-test-parameterized '("red" bold))
|
|
'(face (:foreground "red" :weight bold))))
|
|
(should-error
|
|
(tp-layer-props-with-args 'tp-layer-test-parameterized '("red")))
|
|
(should-error
|
|
(tp-layer-props-with-args
|
|
'tp-layer-test-parameterized '("red" bold extra)))))
|
|
|
|
(ert-deftest tp-layer-test-whole-string-call-supports-wrapped-arguments ()
|
|
"A multi-argument recipe accepts a wrapped argument list plus extras."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-card (foreground background)
|
|
`(face (:foreground ,foreground :background ,background)))
|
|
(let ((text (tp-set "card" 'tp-layer-test-card
|
|
'("white" "navy") 'help-echo "Card")))
|
|
(should
|
|
(equal (get-text-property 0 'face text)
|
|
'(:foreground "white" :background "navy")))
|
|
(should (equal (get-text-property 0 'help-echo text) "Card")))))
|
|
|
|
(ert-deftest tp-layer-test-nested-recipes-compose-direct-properties ()
|
|
"Recipe keys expand recursively and use native merge semantics."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-color (color)
|
|
`(face (:foreground ,color)))
|
|
(define-tp tp-layer-test-button (color)
|
|
`(tp-layer-test-color ,color
|
|
face (:weight bold)
|
|
mouse-face highlight))
|
|
(should
|
|
(equal (tp-layer-props-with-arg 'tp-layer-test-button "red")
|
|
'(face (:foreground "red" :weight bold)
|
|
mouse-face highlight)))))
|
|
|
|
(ert-deftest tp-layer-test-cycle-errors-name-the-path ()
|
|
"Cyclic recipe references fail instead of partially expanding."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-a () '(tp-layer-test-b t))
|
|
(let ((error
|
|
(should-error
|
|
(eval '(define-tp tp-layer-test-b ()
|
|
'(tp-layer-test-a t))))))
|
|
(let ((message (error-message-string error)))
|
|
(should (string-match-p "tp-layer-test-a" message))
|
|
(should (string-match-p "tp-layer-test-b" message))
|
|
(should (string-match-p " -> " message))))))
|
|
|
|
(ert-deftest tp-layer-test-group-merges-ordered-contributions ()
|
|
"A group expands into ordered direct property contributions."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-base () '(face (:weight bold)))
|
|
(define-tps tp-layer-test-group ()
|
|
'tp-layer-test-base
|
|
'(face (:foreground "cyan"))
|
|
'(help-echo "group"))
|
|
(let ((text (tp-set "group" 'tp-layer-test-group)))
|
|
(should
|
|
(equal (get-text-property 0 'face text)
|
|
'(:weight bold :foreground "cyan")))
|
|
(should (equal (get-text-property 0 'help-echo text) "group")))))
|
|
|
|
(ert-deftest tp-layer-test-parameterized-group-evaluates-at-application ()
|
|
"Parameterized groups remain recipes and are not frozen at definition."
|
|
(tp-layer-test--isolated
|
|
(define-tps tp-layer-test-theme (foreground background)
|
|
`(face (:foreground ,foreground))
|
|
`(face (:background ,background)))
|
|
(should
|
|
(equal (tp-group-props-with-args
|
|
'tp-layer-test-theme '("white" "black"))
|
|
'((face (:foreground "white"))
|
|
(face (:background "black")))))))
|
|
|
|
(ert-deftest tp-layer-test-static-named-group-element-compiles-style ()
|
|
"A named static group element also becomes a named direct style."
|
|
(tp-layer-test--isolated
|
|
(define-tps tp-layer-test-parts ()
|
|
'("label" . (face italic mouse-face highlight)))
|
|
(should
|
|
(equal (tp-style-declarations 'tp-layer-test-parts-label)
|
|
'(text/face italic text/mouse-face highlight)))))
|
|
|
|
(ert-deftest tp-layer-test-group-redefinition-removes-generated-recipes ()
|
|
"Redefining a group removes generated recipes no longer present."
|
|
(tp-layer-test--isolated
|
|
(define-tps tp-layer-test-parts ()
|
|
'("old" . (face bold)))
|
|
(should (tp-layer-props 'tp-layer-test-parts-old))
|
|
(define-tps tp-layer-test-parts ()
|
|
'("new" . (face italic)))
|
|
(should-not (tp-layer-props 'tp-layer-test-parts-old))
|
|
(should (tp-layer-props 'tp-layer-test-parts-new))))
|
|
|
|
(ert-deftest tp-layer-test-failed-group-definition-leaves-no-registry-state ()
|
|
"A failed first group definition must not publish partial entries."
|
|
(tp-layer-test--isolated
|
|
(should-error
|
|
(eval '(define-tps tp-layer-test-broken ()
|
|
'("label" . (face)))))
|
|
(should-not (assq 'tp-layer-test-broken tp-layer-groups))
|
|
(should-not (tp-layer-props 'tp-layer-test-broken-label))
|
|
(should-not (tp-style-declarations 'tp-layer-test-broken-label))))
|
|
|
|
(ert-deftest tp-layer-test-failed-group-redefinition-preserves-old-state ()
|
|
"A failed group redefinition must leave every old entry usable."
|
|
(tp-layer-test--isolated
|
|
(define-tps tp-layer-test-atomic ()
|
|
'("old" . (face bold help-echo "old")))
|
|
(let ((old-group (tp-group-props 'tp-layer-test-atomic))
|
|
(old-layer (tp-layer-props 'tp-layer-test-atomic-old))
|
|
(old-style (tp-style-declarations 'tp-layer-test-atomic-old)))
|
|
(should-error
|
|
(eval '(define-tps tp-layer-test-atomic ()
|
|
'("new" . (face)))))
|
|
(should (equal (tp-group-props 'tp-layer-test-atomic) old-group))
|
|
(should (equal (tp-layer-props 'tp-layer-test-atomic-old) old-layer))
|
|
(should (equal (tp-style-declarations 'tp-layer-test-atomic-old)
|
|
old-style))
|
|
(should-not (tp-layer-props 'tp-layer-test-atomic-new))
|
|
(should-not (tp-style-declarations 'tp-layer-test-atomic-new)))))
|
|
|
|
(ert-deftest tp-layer-test-failed-second-generated-install-rolls-back ()
|
|
"A failed generated recipe install must preserve the complete old group."
|
|
(tp-layer-test--isolated
|
|
(define-tps tp-layer-test-atomic-install ()
|
|
'("old-a" . (face bold help-echo "old-a"))
|
|
'("old-b" . (face italic help-echo "old-b")))
|
|
(let ((old-group (tp-group-props 'tp-layer-test-atomic-install))
|
|
(old-a-layer (tp-layer-props 'tp-layer-test-atomic-install-old-a))
|
|
(old-b-layer (tp-layer-props 'tp-layer-test-atomic-install-old-b))
|
|
(old-a-style
|
|
(tp-style-declarations 'tp-layer-test-atomic-install-old-a))
|
|
(old-b-style
|
|
(tp-style-declarations 'tp-layer-test-atomic-install-old-b))
|
|
(old-generated
|
|
(cdr (assq 'tp-layer-test-atomic-install
|
|
tp--group-generated-layers)))
|
|
(install-count 0)
|
|
(original-define
|
|
(symbol-function 'tp--candidate-define-layer-recipe)))
|
|
(cl-letf (((symbol-function 'tp--candidate-define-layer-recipe)
|
|
(lambda (name arglist body layers groups styles compiled)
|
|
(if (and (memq name '(tp-layer-test-atomic-install-new-a
|
|
tp-layer-test-atomic-install-new-b))
|
|
(= (cl-incf install-count) 2))
|
|
(error "synthetic second generated install failure")
|
|
(funcall original-define
|
|
name arglist body
|
|
layers groups styles compiled)))))
|
|
(should-error
|
|
(eval '(define-tps tp-layer-test-atomic-install ()
|
|
'("new-a" . (face underline help-echo "new-a"))
|
|
'("new-b" . (face shadow help-echo "new-b"))))))
|
|
(should (equal (tp-group-props 'tp-layer-test-atomic-install)
|
|
old-group))
|
|
(should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-a)
|
|
old-a-layer))
|
|
(should (equal (tp-layer-props 'tp-layer-test-atomic-install-old-b)
|
|
old-b-layer))
|
|
(should
|
|
(equal (tp-style-declarations 'tp-layer-test-atomic-install-old-a)
|
|
old-a-style))
|
|
(should
|
|
(equal (tp-style-declarations 'tp-layer-test-atomic-install-old-b)
|
|
old-b-style))
|
|
(should (equal (cdr (assq 'tp-layer-test-atomic-install
|
|
tp--group-generated-layers))
|
|
old-generated))
|
|
(should-not (tp-layer-props 'tp-layer-test-atomic-install-new-a))
|
|
(should-not (tp-layer-props 'tp-layer-test-atomic-install-new-b))
|
|
(should-not
|
|
(tp-style-declarations 'tp-layer-test-atomic-install-new-a))
|
|
(should-not
|
|
(tp-style-declarations 'tp-layer-test-atomic-install-new-b)))))
|
|
|
|
(ert-deftest tp-layer-test-definition-results-are-defensive-copies ()
|
|
"Mutating one expanded result cannot corrupt the stored recipe."
|
|
(tp-layer-test--isolated
|
|
(define-tp tp-layer-test-copy ()
|
|
'(face (:foreground "red")))
|
|
(let ((first (tp-layer-props 'tp-layer-test-copy)))
|
|
(setcar (cdr (plist-get first 'face)) "blue")
|
|
(should
|
|
(equal (tp-layer-props 'tp-layer-test-copy)
|
|
'(face (:foreground "red")))))))
|
|
|
|
(ert-deftest tp-layer-test-recipe-owns-mutable-values-and-keeps-identities ()
|
|
"Recipe storage and expansion isolate data without cloning opaque values."
|
|
(tp-layer-test--isolated
|
|
(let* ((caller-string (copy-sequence "tooltip"))
|
|
(caller-vector (vector (copy-sequence "display")))
|
|
(record (tp--make-native-range 'owner :test 1 2))
|
|
(calls 0)
|
|
(callback (lambda (&rest _args) (cl-incf calls))))
|
|
(eval
|
|
`(define-tp tp-layer-test-deep-copy ()
|
|
(list 'help-echo ',caller-string
|
|
'display ',caller-vector
|
|
'tp-test-record ',record
|
|
'action ',callback)))
|
|
(let* ((first (tp-layer-props 'tp-layer-test-deep-copy))
|
|
(first-string (plist-get first 'help-echo))
|
|
(first-vector (plist-get first 'display)))
|
|
(should-not (eq first-string caller-string))
|
|
(should-not (eq first-vector caller-vector))
|
|
(should-not (eq (aref first-vector 0) (aref caller-vector 0)))
|
|
(should (eq (plist-get first 'tp-test-record) record))
|
|
(should (eq (plist-get first 'action) callback))
|
|
(should (= calls 0))
|
|
(aset caller-string 0 ?T)
|
|
(aset (aref caller-vector 0) 0 ?D)
|
|
(should (equal first-string "tooltip"))
|
|
(should (equal first-vector ["display"]))
|
|
(aset first-string 1 ?O)
|
|
(aset (aref first-vector 0) 1 ?I)
|
|
(should
|
|
(equal (tp-layer-props 'tp-layer-test-deep-copy)
|
|
(list 'help-echo "tooltip"
|
|
'display ["display"]
|
|
'tp-test-record record
|
|
'action callback)))))))
|
|
|
|
(ert-deftest tp-layer-test-legacy-dollar-syntax-is-rejected ()
|
|
"Legacy dollar-variable syntax cannot recreate a hidden watcher runtime."
|
|
(tp-layer-test--isolated
|
|
(should-error
|
|
(eval '(define-tp tp-layer-test-reactive ()
|
|
'(face (:foreground $tp-layer-test-color))))
|
|
:type 'tp-invalid-layer-definition)))
|
|
|
|
(ert-deftest tp-layer-test-computed-source-uses-the-shared-policy-core ()
|
|
"Explicit computed sources evaluate through ordinary property projection."
|
|
(tp-layer-test--isolated
|
|
(let ((color "red") (calls 0))
|
|
(define-tp tp-layer-test-computed ()
|
|
`(face ,(tp-computed
|
|
(lambda ()
|
|
(cl-incf calls)
|
|
(list :foreground color)))))
|
|
(let ((text (tp-set "computed" 'tp-layer-test-computed)))
|
|
(should (equal (get-text-property 0 'face text)
|
|
'(:foreground "red")))
|
|
(should (= calls 1))))))
|
|
|
|
(ert-deftest tp-layer-test-literal-function-property-is-not-called ()
|
|
"Literal function values remain callbacks when a recipe is applied."
|
|
(tp-layer-test--isolated
|
|
(let* ((calls 0)
|
|
(callback (lambda (&rest _args) (cl-incf calls))))
|
|
(eval `(define-tp tp-layer-test-help ()
|
|
(list 'help-echo ,callback)))
|
|
(let ((text (tp-set "help" 'tp-layer-test-help)))
|
|
(should (eq (get-text-property 0 'help-echo text) callback))
|
|
(should (= calls 0))))))
|
|
|
|
(provide 'tp-layer-tests)
|
|
;;; tp-layer-tests.el ends here
|