333 lines
14 KiB
EmacsLisp
333 lines
14 KiB
EmacsLisp
;;; tp-style-tests.el --- Tests for TP property policies -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Contract tests for CSS-independent native property policies, direct
|
|
;; declarations, and explicit computed values.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp-style)
|
|
(require 'tp-layer)
|
|
|
|
(defmacro tp-style-test--isolated (&rest body)
|
|
"Run BODY with isolated TP property and named-style registries."
|
|
(declare (indent 0) (debug t))
|
|
`(let ((tp--property-policies (make-hash-table :test #'eq))
|
|
(tp--property-policy-order nil)
|
|
(tp--named-styles (make-hash-table :test #'eq)))
|
|
(tp--register-default-text-properties)
|
|
,@body))
|
|
|
|
(defun tp-style-test--color-policy ()
|
|
"Register and return a direct demo color policy."
|
|
(tp-define-property-policy
|
|
'demo/color
|
|
:normalizer #'downcase
|
|
:validator #'stringp
|
|
:equality #'equal
|
|
:projector (lambda (value)
|
|
(list 'face (list :foreground value)))))
|
|
|
|
(ert-deftest tp-style-test-paint-slot-keeps-one-face-address ()
|
|
"Updating a paint slot changes its face without rewriting text properties."
|
|
(let* ((slot (tp-paint-slot-create '(:foreground "red")))
|
|
(face (tp-paint-slot-face slot))
|
|
(text (propertize "x" 'face face))
|
|
(buffer (generate-new-buffer " *tp-paint-slot-test*")))
|
|
(should (facep face))
|
|
(should (eq face (get-text-property 0 'face text)))
|
|
(tp-paint-slot-update slot '(:foreground "red"))
|
|
(should (equal "red" (face-attribute face :foreground nil nil)))
|
|
(tp-paint-slot-update slot '(:foreground "blue"))
|
|
(should (eq face (get-text-property 0 'face text)))
|
|
(should (equal "blue" (face-attribute face :foreground nil nil)))
|
|
(unwind-protect
|
|
(let ((journal
|
|
(tp-paint-slot-apply-updates
|
|
buffer (list (cons slot '(:foreground "green"))))))
|
|
(with-current-buffer buffer
|
|
(should
|
|
(equal '(:foreground "green")
|
|
(cadr (assq face face-remapping-alist)))))
|
|
(tp-paint-slot-rollback-updates journal)
|
|
(with-current-buffer buffer
|
|
(should-not (assq face face-remapping-alist)))
|
|
(should (equal "blue" (face-attribute face :foreground nil nil))))
|
|
(kill-buffer buffer))))
|
|
|
|
(ert-deftest tp-style-test-policy-registration-is-atomic ()
|
|
"Invalid replacement leaves the previous valid policy installed."
|
|
(tp-style-test--isolated
|
|
(let ((policy (tp-style-test--color-policy)))
|
|
(should (eq policy (tp-property-policy 'demo/color)))
|
|
(should-error
|
|
(tp-define-property-policy 'demo/color :normalizer 42)
|
|
:type 'tp-invalid-property-policy)
|
|
(should (eq policy (tp-property-policy 'demo/color)))
|
|
(should-error
|
|
(tp-define-property-policy 'color)
|
|
:type 'tp-invalid-property-policy))))
|
|
|
|
(ert-deftest tp-style-test-policy-rejects-css-schema-options ()
|
|
"TP property policies reject CSS inheritance and shorthand fields."
|
|
(tp-style-test--isolated
|
|
(dolist (options '((:initial "black")
|
|
(:inherits t)
|
|
(:shorthand identity)))
|
|
(should-error
|
|
(apply #'tp-define-property-policy 'demo/color options)
|
|
:type 'tp-invalid-property-policy))))
|
|
|
|
(ert-deftest tp-style-test-direct-declarations-require-registered-properties ()
|
|
"Direct declarations cannot silently introduce an unknown vocabulary."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-policy)
|
|
(should
|
|
(equal (tp-merge-declarations
|
|
'(demo/color "red")
|
|
'(demo/color nil))
|
|
'(demo/color nil)))
|
|
(should-error
|
|
(tp-merge-declarations '(demo/unknown 1))
|
|
:type 'tp-invalid-declaration)))
|
|
|
|
(ert-deftest tp-style-test-text-declarations-copy-mutable-values ()
|
|
"Text declarations do not retain caller-owned strings or vectors."
|
|
(tp-style-test--isolated
|
|
(let* ((caller-string (copy-sequence "label"))
|
|
(caller-vector (vector (copy-sequence "display")))
|
|
(declarations
|
|
(tp-text-declarations
|
|
(list 'help-echo caller-string 'display caller-vector)))
|
|
(copied-string (plist-get declarations 'text/help-echo))
|
|
(copied-vector (plist-get declarations 'text/display)))
|
|
(should-not (eq copied-string caller-string))
|
|
(should-not (eq copied-vector caller-vector))
|
|
(should-not (eq (aref copied-vector 0) (aref caller-vector 0)))
|
|
(aset caller-string 0 ?L)
|
|
(aset (aref caller-vector 0) 0 ?D)
|
|
(should (equal copied-string "label"))
|
|
(should (equal copied-vector ["display"]))
|
|
(aset copied-string 1 ?A)
|
|
(aset (aref copied-vector 0) 1 ?I)
|
|
(should (equal caller-string "Label"))
|
|
(should (equal caller-vector ["Display"])))))
|
|
|
|
(ert-deftest tp-style-test-direct-merge-defensively-copies-values ()
|
|
"Merged declarations isolate mutable values and preserve functions."
|
|
(tp-style-test--isolated
|
|
(dolist (property '(demo/string demo/vector demo/callback))
|
|
(tp-define-property-policy property))
|
|
(let* ((calls 0)
|
|
(caller-string (copy-sequence "source"))
|
|
(caller-vector (vector (copy-sequence "nested")))
|
|
(callback (lambda () (cl-incf calls)))
|
|
(merged
|
|
(tp-merge-declarations
|
|
(list 'demo/string caller-string
|
|
'demo/vector caller-vector
|
|
'demo/callback callback)))
|
|
(merged-string (plist-get merged 'demo/string))
|
|
(merged-vector (plist-get merged 'demo/vector))
|
|
(merged-callback (plist-get merged 'demo/callback)))
|
|
(should-not (eq merged-string caller-string))
|
|
(should-not (eq merged-vector caller-vector))
|
|
(should-not (eq (aref merged-vector 0) (aref caller-vector 0)))
|
|
(should (eq merged-callback callback))
|
|
(should (functionp merged-callback))
|
|
(should (= calls 0))
|
|
(aset caller-string 0 ?S)
|
|
(aset (aref caller-vector 0) 0 ?N)
|
|
(should (equal merged-string "source"))
|
|
(should (equal merged-vector ["nested"]))
|
|
(aset merged-string 1 ?O)
|
|
(aset (aref merged-vector 0) 1 ?E)
|
|
(should (equal caller-string "Source"))
|
|
(should (equal caller-vector ["Nested"])))))
|
|
|
|
(ert-deftest tp-style-test-literal-functions-are-never-called ()
|
|
"Function values remain data unless wrapped by `tp-computed'."
|
|
(tp-style-test--isolated
|
|
(let* ((calls 0)
|
|
(callback (lambda () (cl-incf calls))))
|
|
(tp-define-property-policy
|
|
'demo/help :projector (lambda (value) (list 'help-echo value)))
|
|
(let ((projected
|
|
(tp--project-declarations (list 'demo/help callback))))
|
|
(should (eq (plist-get projected 'help-echo) callback))
|
|
(should (= calls 0))))))
|
|
|
|
(ert-deftest tp-style-test-computed-runs-once-and-result-stays-literal ()
|
|
"Tagged computation runs once and never invokes its returned function."
|
|
(tp-style-test--isolated
|
|
(let ((compute-calls 0)
|
|
(result-calls 0)
|
|
result-function)
|
|
(setq result-function (lambda () (cl-incf result-calls)))
|
|
(tp-define-property-policy
|
|
'demo/help :projector (lambda (value) (list 'help-echo value)))
|
|
(let ((projected
|
|
(tp--project-declarations
|
|
(list 'demo/help
|
|
(tp-computed
|
|
(lambda ()
|
|
(cl-incf compute-calls)
|
|
result-function))))))
|
|
(should (eq (plist-get projected 'help-echo) result-function))
|
|
(should (= compute-calls 1))
|
|
(should (= result-calls 0))))))
|
|
|
|
(ert-deftest tp-style-test-computed-p-distinguishes-literal-functions ()
|
|
"Only explicit computed wrappers satisfy the public predicate."
|
|
(let ((function (lambda () "value")))
|
|
(should-not (tp-computed-p function))
|
|
(should (tp-computed-p (tp-computed function)))))
|
|
|
|
(ert-deftest tp-style-test-public-resolver-only-executes-computed-sources ()
|
|
"The public resolver preserves literal functions and evaluates tags."
|
|
(let ((literal (lambda () 'literal))
|
|
(calls 0))
|
|
(should (eq (tp-resolve-value literal) literal))
|
|
(should
|
|
(equal (tp-resolve-value
|
|
(tp-computed (lambda () (cl-incf calls) '(computed value))))
|
|
'(computed value)))
|
|
(should (= calls 1))))
|
|
|
|
(ert-deftest tp-style-test-policy-normalizes-validates-and-projects ()
|
|
"A direct value passes through one policy pipeline exactly once."
|
|
(tp-style-test--isolated
|
|
(let ((normalizations 0) (validations 0) (projections 0))
|
|
(tp-define-property-policy
|
|
'demo/color
|
|
:normalizer (lambda (value) (cl-incf normalizations) (downcase value))
|
|
:validator (lambda (value) (cl-incf validations) (stringp value))
|
|
:projector (lambda (value)
|
|
(cl-incf projections)
|
|
(list 'face (list :foreground value))))
|
|
(should
|
|
(equal (tp--project-declarations '(demo/color "RED"))
|
|
'(face (:foreground "red"))))
|
|
(should (equal (list normalizations validations projections) '(1 1 1)))
|
|
(should-error
|
|
(tp--project-declarations '(demo/color 42))
|
|
:type 'tp-invalid-declaration))))
|
|
|
|
(ert-deftest tp-style-test-validator-rejection-is-explicit ()
|
|
"A false validator result raises a direct declaration error."
|
|
(tp-style-test--isolated
|
|
(tp-define-property-policy 'demo/count :validator #'natnump)
|
|
(should-error
|
|
(tp--project-declarations '(demo/count -1))
|
|
:type 'tp-invalid-declaration)))
|
|
|
|
(ert-deftest tp-style-test-native-properties-preserve-functions-and-nil ()
|
|
"Native projectors keep callbacks literal and explicit nil present."
|
|
(tp-style-test--isolated
|
|
(let* ((callback (lambda (_window _object _position) "help"))
|
|
(projected
|
|
(tp--project-text-declarations
|
|
(list 'help-echo callback
|
|
'keymap nil
|
|
'display '(space :width 4)))))
|
|
(should (eq (plist-get projected 'help-echo) callback))
|
|
(should (plist-member projected 'keymap))
|
|
(should-not (plist-get projected 'keymap))
|
|
(should (equal (plist-get projected 'display) '(space :width 4))))))
|
|
|
|
(ert-deftest tp-style-test-native-face-policy-merges-contributions ()
|
|
"The native face policy retains TP's established face merge semantics."
|
|
(tp-style-test--isolated
|
|
(let* ((policy (tp-register-text-property 'face))
|
|
(merge (tp-property-policy-merge policy)))
|
|
(should
|
|
(equal (funcall merge '(:foreground "red") '(:weight bold))
|
|
'(:foreground "red" :weight bold))))))
|
|
|
|
(ert-deftest tp-style-test-define-tp-compiles-static-direct-declarations ()
|
|
"A static `define-tp' layer compiles into a named direct style."
|
|
(tp-style-test--isolated
|
|
(unwind-protect
|
|
(progn
|
|
(define-tp tp-style-test-layer ()
|
|
'(face (:weight bold) help-echo "Demo"))
|
|
(should
|
|
(equal (tp-style-declarations 'tp-style-test-layer)
|
|
'(text/face (:weight bold) text/help-echo "Demo"))))
|
|
(tp-undefine-layer 'tp-style-test-layer))))
|
|
|
|
(ert-deftest tp-style-test-parameterized-layer-has-no-frozen-style ()
|
|
"A parameterized redefinition removes its former static style."
|
|
(tp-style-test--isolated
|
|
(unwind-protect
|
|
(progn
|
|
(define-tp tp-style-test-layer () '(face bold))
|
|
(should (tp-style-declarations 'tp-style-test-layer))
|
|
(define-tp tp-style-test-layer (weight)
|
|
`(face (:weight ,weight)))
|
|
(should-not (tp-style-declarations 'tp-style-test-layer)))
|
|
(tp-undefine-layer 'tp-style-test-layer))))
|
|
|
|
(ert-deftest tp-style-test-static-group-element-compiles-style ()
|
|
"A generated static group layer becomes a named direct style."
|
|
(tp-style-test--isolated
|
|
(unwind-protect
|
|
(progn
|
|
(define-tps tp-style-test-group ()
|
|
'("label" . (face italic mouse-face highlight)))
|
|
(should
|
|
(equal (tp-style-declarations 'tp-style-test-group-label)
|
|
'(text/face italic text/mouse-face highlight))))
|
|
(tp-undefine-group 'tp-style-test-group))))
|
|
|
|
(ert-deftest tp-style-test-named-styles-are-defensive ()
|
|
"Named styles own declarations and return defensive copies."
|
|
(tp-style-test--isolated
|
|
(dolist (property '(demo/title demo/layout))
|
|
(tp-define-property-policy property))
|
|
(let* ((title (copy-sequence "button"))
|
|
(layout (vector (copy-sequence "row")))
|
|
(merged
|
|
(tp-merge-declarations
|
|
(list 'demo/title title 'demo/layout layout))))
|
|
(tp-define-style 'demo/button merged)
|
|
(aset (plist-get merged 'demo/title) 0 ?B)
|
|
(aset (aref (plist-get merged 'demo/layout) 0) 0 ?R)
|
|
(should
|
|
(equal (tp-style-declarations 'demo/button)
|
|
'(demo/title "button" demo/layout ["row"])))
|
|
(let* ((first (tp-style-declarations 'demo/button))
|
|
(first-title (plist-get first 'demo/title))
|
|
(first-layout (plist-get first 'demo/layout)))
|
|
(aset first-title 1 ?U)
|
|
(aset (aref first-layout 0) 1 ?O)
|
|
(should (equal (plist-get merged 'demo/title) "Button"))
|
|
(should (equal (plist-get merged 'demo/layout) ["Row"]))
|
|
(should
|
|
(equal (tp-style-declarations 'demo/button)
|
|
'(demo/title "button" demo/layout ["row"])))))))
|
|
|
|
(ert-deftest tp-style-test-css-engine-symbols-are-not-owned-by-tp ()
|
|
"TP does not expose the CSS cascade surface migrated to ECSS."
|
|
(dolist (symbol '(tp-subject-create
|
|
tp-subject-set-children
|
|
tp-selector-match-p
|
|
tp-selector-specificity
|
|
tp-stylesheet-create
|
|
tp-stylesheet-add-rule
|
|
tp-compute-style
|
|
tp-project-style
|
|
tp-wide-value
|
|
tp-important
|
|
tp-var))
|
|
(should-not (fboundp symbol)))
|
|
(should-not (featurep 'ecss)))
|
|
|
|
(provide 'tp-style-tests)
|
|
;;; tp-style-tests.el ends here
|