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