tp/tests/tp-style-tests.el

;;; 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)

(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
  "Snapshots compare by prompts, menu order, parents and literal commands."
  (let* ((factory (eval '(lambda ()
                          (let ((n 0))
                            (lambda () (setq n (1+ n))))) t))
         (first (funcall factory)) (second (funcall factory))
         (map (make-keymap "Root"))
         (prefix (make-sparse-keymap "Prefix"))
         (parent (make-sparse-keymap "Parent")))
    (define-key map (kbd "RET") first)
    (define-key map [t] #'ignore)
    (define-key prefix [self] prefix)
    (define-key prefix [one] '(menu-item "One" ignore))
    (define-key prefix [two] '(menu-item "Two" forward-char))
    (define-key map [prefix] prefix)
    (define-key parent [inherited] #'backward-char)
    (set-keymap-parent map parent)
    (should (equal first second))
    (should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
    (dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
                   callback default inherited))
      (let ((copy (tp-property-value-copy map)))
        (pcase kind
          ((or 'root-prompt 'prefix-prompt 'parent-prompt)
           (let* ((target (pcase kind
                            ('root-prompt copy)
                            ('prefix-prompt (lookup-key copy [prefix]))
                            ('parent-prompt (keymap-parent copy))))
                  (cell (memq (keymap-prompt target) target)))
             (setcar cell "Changed")))
          ('menu-order
           (let* ((target (lookup-key copy [prefix]))
                  (one (lookup-key target [one])))
             (define-key target [one] nil t)
             (define-key target [one] one)))
          ('callback (define-key copy (kbd "RET") second))
          ('default (define-key copy [t] #'forward-char))
          ('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
        (should-not (tp--native-property-value-equal-p map copy))))))

(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