ef31a67beb
Introduce the pure TP 1.0 property schema, selector, cascade, custom-property, computed-value, provenance, and Emacs projection kernel. Compile static legacy layer definitions into canonical named styles without freezing parameterized or reactive definitions.\n\nVerified with 667 ERT tests, 92 doctests, shuffled seed 20260806, and compile-all with warnings as errors.
518 lines
22 KiB
EmacsLisp
518 lines
22 KiB
EmacsLisp
;;; tp-style-tests.el --- Tests for TP style cascade -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Geekinney
|
|
|
|
;;; Commentary:
|
|
|
|
;; Contract tests for the TP 1.0 schema-driven cascade kernel.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp-style)
|
|
(require 'tp-layer)
|
|
|
|
(defmacro tp-style-test--isolated (&rest body)
|
|
"Run BODY with empty TP style registries."
|
|
(declare (indent 0) (debug t))
|
|
`(let ((tp--property-schemas (make-hash-table :test #'eq))
|
|
(tp--property-schema-order nil)
|
|
(tp--named-styles (make-hash-table :test #'eq))
|
|
(tp--stylesheet-rules nil)
|
|
(tp--cascade-layers nil)
|
|
(tp--style-source-order 0))
|
|
(tp-style-reset)
|
|
,@body))
|
|
|
|
(defun tp-style-test--color-schema (&optional inherits)
|
|
"Register and return the demo color schema using INHERITS."
|
|
(tp-define-property
|
|
'demo/color
|
|
:initial "black"
|
|
:inherits inherits
|
|
:normalizer #'downcase
|
|
:validator #'stringp
|
|
:equality #'equal
|
|
:projector (lambda (value)
|
|
(list 'face (list :foreground value)))))
|
|
|
|
(defun tp-style-test--values (subject &rest args)
|
|
"Return computed values for SUBJECT using ARGS."
|
|
(tp-computed-style-values
|
|
(apply #'tp-compute-style subject args)))
|
|
|
|
(ert-deftest tp-style-test-schema-registration-is-atomic-and-defensive ()
|
|
"Invalid replacement leaves the previous valid schema installed."
|
|
(tp-style-test--isolated
|
|
(let ((schema (tp-style-test--color-schema t)))
|
|
(should (eq schema (tp-property-schema 'demo/color)))
|
|
(should-error
|
|
(tp-define-property 'demo/color :normalizer 42)
|
|
:type 'tp-invalid-property-schema)
|
|
(should (eq schema (tp-property-schema 'demo/color)))
|
|
(should-error
|
|
(tp-define-property 'color :initial "black")
|
|
:type 'tp-invalid-property-schema))))
|
|
|
|
(ert-deftest tp-style-test-shorthand-expands-before-cascade-once ()
|
|
"A shorthand expands once into registered canonical longhands."
|
|
(tp-style-test--isolated
|
|
(let ((calls 0))
|
|
(tp-define-property 'demo/top :initial 0 :validator #'natnump)
|
|
(tp-define-property 'demo/right :initial 0 :validator #'natnump)
|
|
(tp-define-property
|
|
'demo/inset
|
|
:shorthand (lambda (value)
|
|
(cl-incf calls)
|
|
(list 'demo/top value 'demo/right value)))
|
|
(let ((values (tp-style-test--values
|
|
(tp-subject-create :type 'box)
|
|
:declarations '(demo/inset 7))))
|
|
(should (= calls 1))
|
|
(should (= (plist-get values 'demo/top) 7))
|
|
(should (= (plist-get values 'demo/right) 7))
|
|
(should-not (plist-member values 'demo/inset))))))
|
|
|
|
(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 'text/help :initial nil)
|
|
(let ((values (tp-style-test--values
|
|
(tp-subject-create :type 'label)
|
|
:declarations (list 'text/help callback))))
|
|
(should (eq (plist-get values 'text/help) 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 'text/help :initial nil)
|
|
(let ((values
|
|
(tp-style-test--values
|
|
(tp-subject-create :type 'label)
|
|
:declarations
|
|
(list 'text/help
|
|
(tp-computed
|
|
(lambda ()
|
|
(cl-incf compute-calls)
|
|
result-function))))))
|
|
(should (eq (plist-get values 'text/help) result-function))
|
|
(should (= compute-calls 1))
|
|
(should (= result-calls 0))))))
|
|
|
|
(ert-deftest tp-style-test-inheritance-is-property-specific ()
|
|
"Only schemas marked inheriting read their parent's computed value."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema t)
|
|
(tp-define-property 'demo/background :initial "transparent"
|
|
:validator #'stringp)
|
|
(let* ((parent (tp-subject-create :type 'panel))
|
|
(child (tp-subject-create :type 'label :parent parent))
|
|
(parent-result
|
|
(tp-compute-style
|
|
parent :declarations
|
|
'(demo/color "NAVY" demo/background "white")))
|
|
(values
|
|
(tp-style-test--values
|
|
child :parent-style parent-result)))
|
|
(should (equal (plist-get values 'demo/color) "navy"))
|
|
(should (equal (plist-get values 'demo/background) "transparent")))))
|
|
|
|
(ert-deftest tp-style-test-explicit-nil-is-not-absence ()
|
|
"An explicit nil declaration overrides an inherited non-nil value."
|
|
(tp-style-test--isolated
|
|
(tp-define-property 'text/keymap :initial 'default-map :inherits t)
|
|
(let* ((parent (tp-subject-create :type 'panel))
|
|
(child (tp-subject-create :type 'button :parent parent))
|
|
(parent-result
|
|
(tp-compute-style parent :declarations '(text/keymap parent-map)))
|
|
(values
|
|
(tp-style-test--values
|
|
child :parent-style parent-result
|
|
:declarations '(text/keymap nil))))
|
|
(should (plist-member values 'text/keymap))
|
|
(should-not (plist-get values 'text/keymap)))))
|
|
|
|
(ert-deftest tp-style-test-structured-selectors-cover-public-combinators ()
|
|
"Structured selectors match identity, attributes, state, and relations."
|
|
(tp-style-test--isolated
|
|
(let* ((root (tp-subject-create :type 'panel :id "root"))
|
|
(first (tp-subject-create :type 'button :id "cancel"
|
|
:classes '(secondary)))
|
|
(second (tp-subject-create
|
|
:type 'button :id "save" :classes '(primary rounded)
|
|
:attributes '((role . action)) :state '(active)))
|
|
(_children (tp-subject-set-children root (list first second))))
|
|
(should
|
|
(tp-selector-match-p
|
|
'(:and (:type button) (:id "save") (:class primary)
|
|
(:attr role action) (:state active)
|
|
(:not (:class disabled)))
|
|
second))
|
|
(should (tp-selector-match-p
|
|
'(:child (:id "root") (:class primary)) second))
|
|
(should (tp-selector-match-p
|
|
'(:descendant (:type panel) (:id "save")) second))
|
|
(should (tp-selector-match-p
|
|
'(:adjacent (:id "cancel") (:id "save")) second))
|
|
(should (tp-selector-match-p
|
|
'(:sibling (:class secondary) (:id "save")) second))
|
|
(should (tp-selector-match-p
|
|
'(:is (:id "missing") (:class primary)) second))
|
|
(should (tp-selector-match-p
|
|
'(:where (:type button) (:class missing)) second)))))
|
|
|
|
(ert-deftest tp-style-test-origin-importance-and-specificity-are-ordered ()
|
|
"Importance, origin, and selector specificity decide the winner in order."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((subject (tp-subject-create :type 'button :id "save"
|
|
:classes '(primary))))
|
|
(tp-stylesheet-add-rule '(:id "save") '(demo/color "green")
|
|
:origin 'theme)
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
|
:origin 'author)
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"red"))
|
|
(tp-stylesheet-add-rule
|
|
'(:class primary)
|
|
(list 'demo/color (tp-important "purple"))
|
|
:origin 'theme)
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"purple")))))
|
|
|
|
(ert-deftest tp-style-test-layer-order-reverses-for-important ()
|
|
"Normal declarations prefer later layers; important declarations reverse."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((subject (tp-subject-create :type 'button)))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
|
:layer 'base)
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
|
:layer 'components)
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"red"))
|
|
(tp-style-reset-rules)
|
|
(tp-stylesheet-add-rule
|
|
'(:type button) (list 'demo/color (tp-important "blue"))
|
|
:layer 'base)
|
|
(tp-stylesheet-add-rule
|
|
'(:type button) (list 'demo/color (tp-important "red"))
|
|
:layer 'components)
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"blue")))))
|
|
|
|
(ert-deftest tp-style-test-unlayered-normal-beats-layered-normal ()
|
|
"An unlayered normal declaration outranks layered declarations."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((subject (tp-subject-create :type 'button)))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
|
:layer 'components)
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"red")))))
|
|
|
|
(ert-deftest tp-style-test-source-order-breaks-complete-ties ()
|
|
"The last matching rule wins after all stronger dimensions tie."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((subject (tp-subject-create :type 'button)))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue"))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red"))
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"red")))))
|
|
|
|
(ert-deftest tp-style-test-later-duplicate-declaration-wins-stably ()
|
|
"The later declaration wins when one rule repeats a property."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(tp-stylesheet-add-rule
|
|
'(:type label) '(demo/color "red" demo/color "green"))
|
|
(let ((values
|
|
(tp-style-test--values (tp-subject-create :type 'label))))
|
|
(should (equal (plist-get values 'demo/color) "green")))))
|
|
|
|
(ert-deftest tp-style-test-computation-is-deterministic ()
|
|
"Equivalent calls return structurally equal computed styles."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(tp-stylesheet-add-rule '(:class primary) '(demo/color "purple"))
|
|
(let ((subject (tp-subject-create :type 'label :classes '(primary))))
|
|
(should (equal (tp-compute-style subject :provenance t)
|
|
(tp-compute-style subject :provenance t))))))
|
|
|
|
(ert-deftest tp-style-test-custom-properties-have-canonical-order ()
|
|
"Computed custom properties use deterministic symbol-name order."
|
|
(tp-style-test--isolated
|
|
(let* ((result
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'label)
|
|
:declarations '(--zeta 1 --alpha 2 --middle 3)))
|
|
(custom (tp-computed-style-custom-properties result)))
|
|
(should (equal custom '(--alpha 2 --middle 3 --zeta 1))))))
|
|
|
|
(ert-deftest tp-style-test-computation-does-not-mutate-current-buffer ()
|
|
"Cascade computation never mutates the current buffer."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(with-temp-buffer
|
|
(insert "stable")
|
|
(add-text-properties 1 4 '(face bold marker original))
|
|
(let ((before-text (buffer-string))
|
|
(before-properties (text-properties-at 2)))
|
|
(cl-letf (((symbol-function 'add-text-properties)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'put-text-property)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'remove-text-properties)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'set-text-properties)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'insert)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'delete-region)
|
|
(lambda (&rest _) (error "buffer mutation")))
|
|
((symbol-function 'erase-buffer)
|
|
(lambda (&rest _) (error "buffer mutation"))))
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'label)
|
|
:declarations '(demo/color "red")))
|
|
(should (equal (buffer-string) before-text))
|
|
(should (equal (text-properties-at 2) before-properties))))))
|
|
|
|
(ert-deftest tp-style-test-compute-error-leaves-cascade-state-unchanged ()
|
|
"A failing computed source does not mutate registered cascade state."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
|
|
(let ((rules-before (copy-tree tp--stylesheet-rules))
|
|
(order-before tp--style-source-order))
|
|
(should-error
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'label)
|
|
:declarations
|
|
(list 'demo/color (tp-computed (lambda () (error "broken"))))))
|
|
(should (equal tp--stylesheet-rules rules-before))
|
|
(should (= tp--style-source-order order-before)))))
|
|
|
|
(ert-deftest tp-style-test-nearer-scope-wins-after-specificity ()
|
|
"A rule scoped to the nearest matching ancestor wins a tie."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let* ((root (tp-subject-create :type 'panel :id "root"))
|
|
(section (tp-subject-create :type 'section :id "section"))
|
|
(button (tp-subject-create :type 'button)))
|
|
(tp-subject-set-children root (list section))
|
|
(tp-subject-set-children section (list button))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
|
|
:scope '(:id "root"))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
|
:scope '(:id "section"))
|
|
(should (equal (plist-get (tp-style-test--values button) 'demo/color)
|
|
"red")))))
|
|
|
|
(ert-deftest tp-style-test-css-wide-values-are-tagged-not-reserved-symbols ()
|
|
"Tagged wide values work while an ordinary `inherit' symbol stays literal."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema t)
|
|
(tp-define-property 'demo/token :initial 'initial-token :validator #'symbolp)
|
|
(let* ((parent (tp-subject-create :type 'panel))
|
|
(child (tp-subject-create :type 'label :parent parent))
|
|
(parent-result
|
|
(tp-compute-style parent :declarations '(demo/color "red")))
|
|
(values
|
|
(tp-style-test--values
|
|
child :parent-style parent-result
|
|
:declarations
|
|
(list 'demo/color (tp-wide-value 'inherit)
|
|
'demo/token 'inherit))))
|
|
(should (equal (plist-get values 'demo/color) "red"))
|
|
(should (eq (plist-get values 'demo/token) 'inherit)))))
|
|
|
|
(ert-deftest tp-style-test-revert-and-revert-layer-select-lower-candidates ()
|
|
"Revert skips an origin and revert-layer skips only the winning layer."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((subject (tp-subject-create :type 'button)))
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "green")
|
|
:origin 'theme)
|
|
(tp-stylesheet-add-rule '(:type button) '(demo/color "red")
|
|
:origin 'author :layer 'base)
|
|
(tp-stylesheet-add-rule
|
|
'(:type button)
|
|
(list 'demo/color (tp-wide-value 'revert-layer))
|
|
:origin 'author :layer 'components)
|
|
(should (equal (plist-get (tp-style-test--values subject) 'demo/color)
|
|
"red"))
|
|
(should
|
|
(equal
|
|
(plist-get
|
|
(tp-style-test--values
|
|
subject
|
|
:declarations
|
|
(list 'demo/color (tp-wide-value 'revert)))
|
|
'demo/color)
|
|
"red")))))
|
|
|
|
(ert-deftest tp-style-test-custom-properties-inherit-and-support-fallback ()
|
|
"Custom properties inherit and `tp-var' resolves an explicit fallback."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let* ((parent (tp-subject-create :type 'panel))
|
|
(child (tp-subject-create :type 'label :parent parent))
|
|
(parent-result
|
|
(tp-compute-style parent :declarations '(--accent "NAVY")))
|
|
(inherited
|
|
(tp-style-test--values
|
|
child :parent-style parent-result
|
|
:declarations (list 'demo/color (tp-var '--accent))))
|
|
(fallback
|
|
(tp-style-test--values
|
|
child :declarations
|
|
(list 'demo/color (tp-var '--missing "GRAY")))))
|
|
(should (equal (plist-get inherited 'demo/color) "navy"))
|
|
(should (equal (plist-get fallback 'demo/color) "gray")))))
|
|
|
|
(ert-deftest tp-style-test-custom-property-cycle-uses-outer-fallback ()
|
|
"A custom-property cycle is invalid and activates the outer fallback."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((values
|
|
(tp-style-test--values
|
|
(tp-subject-create :type 'label)
|
|
:declarations
|
|
(list '--a (tp-var '--b)
|
|
'--b (tp-var '--a)
|
|
'demo/color (tp-var '--a "SAFE")))))
|
|
(should (equal (plist-get values 'demo/color) "safe")))))
|
|
|
|
(ert-deftest tp-style-test-invalid-value-falls-back-to-inherited-or-initial ()
|
|
"Invalid-at-computed-value declarations use the property's default path."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((values
|
|
(tp-style-test--values
|
|
(tp-subject-create :type 'label)
|
|
:declarations (list 'demo/color (tp-var '--missing)))))
|
|
(should (equal (plist-get values 'demo/color) "black")))))
|
|
|
|
(ert-deftest tp-style-test-invalid-winner-does-not-recascade ()
|
|
"An invalid winner uses its default instead of a lower declaration."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(tp-stylesheet-add-rule '(:type label) '(demo/color "blue"))
|
|
(tp-stylesheet-add-rule
|
|
'(:type label) (list 'demo/color (tp-var '--missing)))
|
|
(let ((values
|
|
(tp-style-test--values (tp-subject-create :type 'label))))
|
|
(should (equal (plist-get values 'demo/color) "black")))))
|
|
|
|
(ert-deftest tp-style-test-provenance-identifies-winning-declaration ()
|
|
"The optional read-only provenance records the winning rule facts."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(tp-stylesheet-add-rule '(:class primary) '(demo/color "purple")
|
|
:origin 'author :layer 'components)
|
|
(let* ((result
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'button :classes '(primary))
|
|
:provenance t))
|
|
(entry (plist-get (tp-computed-style-provenance result)
|
|
'demo/color)))
|
|
(should (equal (plist-get entry :selector) '(:class primary)))
|
|
(should (eq (plist-get entry :origin) 'author))
|
|
(should (eq (plist-get entry :layer) 'components)))))
|
|
|
|
(ert-deftest tp-style-test-projector-produces-final-emacs-properties ()
|
|
"Projection converts canonical computed values to Emacs properties."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((result
|
|
(tp-compute-style
|
|
(tp-subject-create :type 'label)
|
|
:declarations '(demo/color "RED"))))
|
|
(should (equal (tp-project-style result)
|
|
'(face (:foreground "red")))))))
|
|
|
|
(ert-deftest tp-style-test-native-text-schemas-preserve-functions-and-nil ()
|
|
"Native projectors keep callback functions literal and explicit nil present."
|
|
(tp-style-test--isolated
|
|
(let* ((callback (lambda (_window _object _position) "help"))
|
|
(declarations
|
|
(tp-text-declarations
|
|
(list 'help-echo callback 'keymap nil 'display '(space :width 4))))
|
|
(result
|
|
(tp-compute-style (tp-subject-create :type 'label)
|
|
:declarations declarations))
|
|
(projected (tp-project-style result)))
|
|
(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-inactive-nil-native-properties-do-not-project ()
|
|
"Default nil schemas do not create absent Emacs properties."
|
|
(tp-style-test--isolated
|
|
(let ((result (tp-compute-style (tp-subject-create :type 'label))))
|
|
(should-not (tp-project-style result)))))
|
|
|
|
(ert-deftest tp-style-test-define-tp-compiles-static-layer-declarations ()
|
|
"A static `define-tp' layer also becomes a canonical named style."
|
|
(tp-style-test--isolated
|
|
(unwind-protect
|
|
(progn
|
|
(define-tp tp-style-test-layer ()
|
|
'(face (:weight bold) help-echo "Demo" tp-text "content"))
|
|
(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-redefinition-removes-static-style ()
|
|
"A parameterized redefinition cannot leave a frozen static style behind."
|
|
(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 canonical named 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-style-definitions-are-defensive ()
|
|
"Named styles own their declarations instead of caller mutable plists."
|
|
(tp-style-test--isolated
|
|
(tp-style-test--color-schema)
|
|
(let ((declarations (list 'demo/color "red")))
|
|
(tp-define-style 'demo/button declarations)
|
|
(setcar (cdr declarations) "blue")
|
|
(should (equal (tp-style-declarations 'demo/button)
|
|
'(demo/color "red")))
|
|
(let ((copy (tp-style-declarations 'demo/button)))
|
|
(setcar (cdr copy) "green")
|
|
(should (equal (tp-style-declarations 'demo/button)
|
|
'(demo/color "red")))))))
|
|
|
|
(provide 'tp-style-tests)
|
|
;;; tp-style-tests.el ends here
|