tp/tests/tp-style-tests.el

;;; 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-subject-class-and-state-tokens-use-value-equality ()
  "Selectors match generic string tokens without requiring symbol identity."
  (tp-style-test--isolated
    (let ((subject (tp-subject-create
                    :type 'button
                    :classes (list (copy-sequence "primary"))
                    :state (list (copy-sequence "active")))))
      (should (tp-selector-match-p '(:class "primary") subject))
      (should (tp-selector-match-p '(:state "active") subject)))))

(ert-deftest tp-style-test-stylesheet-instances-isolate-rules-and-layers ()
  "Independent stylesheets cannot leak rules or layer order into each other."
  (tp-style-test--isolated
    (tp-style-test--color-schema)
    (let ((left (tp-stylesheet-create))
          (right (tp-stylesheet-create))
          (subject (tp-subject-create :type 'button)))
      (tp-stylesheet-add-rule '(:type button) '(demo/color "blue")
                              :layer 'base :stylesheet left)
      (tp-stylesheet-add-rule '(:type button) '(demo/color "red")
                              :layer 'components :stylesheet left)
      (tp-stylesheet-add-rule '(:type button) '(demo/color "green")
                              :layer 'components :stylesheet right)
      (tp-stylesheet-add-rule '(:type button) '(demo/color "purple")
                              :layer 'base :stylesheet right)
      (should (equal (plist-get
                      (tp-style-test--values subject :rules left)
                      'demo/color)
                     "red"))
      (should (equal (plist-get
                      (tp-style-test--values subject :rules right)
                      'demo/color)
                     "purple"))
      (should (equal (plist-get (tp-style-test--values subject) 'demo/color)
                     "black"))
      (tp-style-reset-rules left)
      (should (equal (plist-get
                      (tp-style-test--values subject :rules left)
                      'demo/color)
                     "black"))
      (should (equal (plist-get
                      (tp-style-test--values subject :rules right)
                      'demo/color)
                     "purple")))))

(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