;;; tp-managed-tests.el --- ERT tests for managed lifecycle APIs -*- lexical-binding: t -*-

;;; Commentary:

;; Stage 4 RED tests for additive managed lifecycle behavior.  These
;; tests intentionally drive public entry points and should fail until
;; managed metadata, diagnostics, transactions, and theme generation are
;; implemented.

;;; Code:

(require 'ert)
(require 'tp)

(defmacro tp-managed-tests--with-clean (&rest body)
  "Run BODY in a temp buffer with clean layer/reactive state."
  (declare (indent 0))
  `(unwind-protect
       (with-temp-buffer
         (tp-layer-reset)
         (tp-reactive-reset)
         (setq tp-reactive-observer-errors nil)
         ,@body)
     (tp-layer-reset)
     (tp-reactive-reset)
     (setq tp-reactive-observer-errors nil)))

(defun tp-managed-tests--require-api (fn)
  "Assert FN exists and return its function binding."
  (should (fboundp fn))
  (symbol-function fn))

(defun tp-managed-tests--raw-intervals ()
  "Return raw text and property intervals for the current buffer."
  (list (buffer-substring-no-properties (point-min) (point-max))
        (tp-intervals (point-min) (point-max) nil t)))

(defun tp-managed-tests--managed-buffer-diagnostics ()
  "Call `tp-managed-buffer-diagnostics' after asserting it exists."
  (tp-managed-tests--require-api 'tp-managed-buffer-diagnostics)
  (tp-managed-buffer-diagnostics (current-buffer)))

(defun tp-managed-tests--managed-layer-diagnostics (layer)
  "Call `tp-managed-layer-diagnostics' for LAYER after asserting it exists."
  (tp-managed-tests--require-api 'tp-managed-layer-diagnostics)
  (tp-managed-layer-diagnostics layer))

(defun tp-managed-tests--managed-diagnostics ()
  "Call `tp-managed-diagnostics' after asserting it exists."
  (tp-managed-tests--require-api 'tp-managed-diagnostics)
  (tp-managed-diagnostics))

(ert-deftest tp-managed-test-metadata-is-not-public-stack-or-rendered ()
  "Managed tp-meta is stripped from public stack query and rendered props."
  (tp-managed-tests--with-clean
    (insert "abcd")
    (tp-put-layer 1 4
                  '(stage4-visible
                    face (:foreground "red")
                    help-echo "visible"
                    tp-meta (:schema 1
                             :entry-id stage4-entry-a
                             :origin inline
                             :args ("red" 7)))
                  0)
    (let* ((stack (tp-layer-stack-at 1))
           (top (cdr (assq 'stage4-visible stack)))
           (rendered (text-properties-at 1)))
      (should (assq 'stage4-visible stack))
      (should-not (plist-member top 'tp-meta))
      (should-not (plist-member rendered 'tp-meta))
      (should (equal (plist-get rendered 'face) '(:foreground "red")))
      (should (equal (plist-get rendered 'help-echo) "visible")))))

(ert-deftest tp-managed-test-parameterized-mounted-layer-retains-args ()
  "Parameterized mounted layer diagnostics retain each entry's args."
  (tp-managed-tests--with-clean
    (insert "abcdefgh")
    (define-tp stage4-color (fg bg)
      `(face (:foreground ,fg :background ,bg)))
    (tp-put-layer 1 4 '(stage4-color "red" "blue") 0)
    (tp-put-layer 5 8 '(stage4-color "green" "black") 0)
    (let* ((diag (tp-managed-tests--managed-layer-diagnostics 'stage4-color))
           (entries (plist-get diag :entries))
           (args (mapcar (lambda (entry) (plist-get entry :args)) entries)))
      (should (member '("red" "blue") args))
      (should (member '("green" "black") args)))))

(ert-deftest tp-managed-test-parameterized-mounted-layer-refreshes-after-redefine ()
  "Parameterized mounted entries re-render from stored args after redefine."
  (tp-managed-tests--with-clean
    (insert "abcdefgh")
    (define-tp stage4-redef (fg bg)
      `(face (:foreground ,fg :background ,bg)))
    (tp-put-layer 1 4 '(stage4-redef "red" "blue") 0)
    (tp-put-layer 5 8 '(stage4-redef "green" "black") 0)
    (define-tp stage4-redef (fg bg)
      `(face (:foreground ,fg :background ,bg :weight bold)))
    (should (equal (get-text-property 1 'face)
                   '(:foreground "red" :background "blue" :weight bold)))
    (should (equal (get-text-property 5 'face)
                   '(:foreground "green" :background "black" :weight bold)))))

(ert-deftest tp-managed-test-attach-finds-inserted-managed-string ()
  "Attach registers layers copied in through a propertized string."
  (tp-managed-tests--with-clean
    (define-tp stage4-attached () '(face (:box t)))
    (let ((payload (copy-sequence "xy")))
      (tp-put-layer payload 'stage4-attached 0)
      (insert payload))
    (tp-managed-tests--require-api 'tp-attach-managed-layers)
    (should (equal (tp-attach-managed-layers 1 3 (current-buffer))
                   '(stage4-attached)))
    (should (equal (tp-reactive-layer-buffers 'stage4-attached)
                   (list (current-buffer))))))

(ert-deftest tp-managed-test-detach-removes-managed-storage-and-keeps-rendered ()
  "Detach with KEEP-RENDERED removes managed storage but preserves visible props."
  (tp-managed-tests--with-clean
    (insert "abcd")
    (define-tp stage4-detach () '(face italic help-echo "kept"))
    (tp-put-layer 1 4 'stage4-detach 0)
    (tp-managed-tests--require-api 'tp-detach-managed-layers)
    (should (equal (tp-detach-managed-layers 1 4 (current-buffer) t)
                   '(stage4-detach)))
    (should-not (plist-member (text-properties-at 1) 'tp-layers))
    (should-not (plist-member (text-properties-at 1) 'tp-meta))
    (should-not (plist-member (text-properties-at 1) 'tp-name))
    (should (eq (get-text-property 1 'face) 'italic))
    (should (equal (get-text-property 1 'help-echo) "kept"))
    (should-not (tp-reactive-layer-buffers 'stage4-detach))))

(ert-deftest tp-managed-test-buffer-diagnostics-are-read-only ()
  "Managed buffer diagnostics do not mutate text, props, point, or modified state."
  (tp-managed-tests--with-clean
    (insert "abcd")
    (define-tp stage4-diag () '(face bold))
    (tp-put-layer 1 4 'stage4-diag 0)
    (goto-char 3)
    (set-buffer-modified-p nil)
    (let ((before-state (tp-managed-tests--raw-intervals))
          (before-point (point))
          (before-modified (buffer-modified-p))
          (before-undo buffer-undo-list))
      (let ((diag (tp-managed-tests--managed-buffer-diagnostics)))
        (should (plist-member diag :layers))
        (should (member 'stage4-diag (plist-get diag :layers))))
      (should (equal (tp-managed-tests--raw-intervals) before-state))
      (should (= (point) before-point))
      (should (eq (buffer-modified-p) before-modified))
      (should (eq buffer-undo-list before-undo)))))

(ert-deftest tp-managed-test-layer-transaction-rolls-back-on-body-error ()
  "tp-layer-transaction restores raw properties when the body errors."
  (tp-managed-tests--with-clean
    (insert "abcdef")
    (define-tp stage4-base () '(face bold help-echo "base"))
    (define-tp stage4-temp () '(face italic help-echo "temp"))
    (tp-put-layer 1 6 'stage4-base 0)
    (let ((before (tp-managed-tests--raw-intervals)))
      (tp-managed-tests--require-api 'tp-layer-transaction)
      (let ((err (should-error
                  (tp-layer-transaction
                   1 6 (current-buffer)
                   (lambda ()
                     (tp-put-layer 1 3 'stage4-temp 0)
                     (error "stage4 boom"))))))
        (should (eq (car err) 'tp-layer-transaction-error)))
      (should (equal (tp-managed-tests--raw-intervals) before)))))

(ert-deftest tp-managed-test-buffer-transaction-rolls-back-length-changes ()
  "Buffer rollback tracks insertions and deletions inside the live range."
  (dolist (mutation '(insert delete))
    (tp-managed-tests--with-clean
      (insert (propertize "abcdef" 'face 'bold))
      (let ((before (buffer-substring (point-min) (point-max))))
        (should-error
         (tp-layer-transaction
          2 5 (current-buffer)
          (lambda ()
            (pcase mutation
              ('insert
               (goto-char 3)
               (insert (propertize "XYZ" 'help-echo "temporary")))
              ('delete
               (delete-region 3 4)))
            (error "length-changing rollback"))))
        (should (equal-including-properties
                 (buffer-substring (point-min) (point-max))
                 before))))))

(ert-deftest tp-managed-test-layer-transaction-success-keeps-body-result ()
  "Successful transactions expose the body's result and changed ranges."
  (tp-managed-tests--with-clean
    (insert "abcd")
    (define-tp stage4-success () '(face bold))
    (let ((result
           (tp-layer-transaction
            1 4 (current-buffer)
            (lambda ()
              (tp-push-layer 1 4 'stage4-success)
              :body-result))))
      (should (eq (plist-get result :status) 'ok))
      (should (eq (plist-get result :ok) t))
      (should (eq (plist-get result :result) :body-result))
      (should (plist-get result :changed-ranges)))))

(ert-deftest tp-managed-test-layer-transaction-noerror-returns-structured-failure ()
  "NOERROR transaction failures return operation data and rollback status."
  (tp-managed-tests--with-clean
    (insert "abcdef")
    (define-tp stage4-base2 () '(face bold))
    (define-tp stage4-temp2 () '(face italic))
    (tp-put-layer 1 6 'stage4-base2 0)
    (let ((before (tp-managed-tests--raw-intervals)))
      (tp-managed-tests--require-api 'tp-layer-transaction)
      (let ((result (tp-layer-transaction
                     1 6 (current-buffer)
                     (lambda ()
                       (tp-put-layer 2 5 'stage4-temp2 0)
                       (signal 'error '("stage4 noerror")))
                     t)))
        (should (eq (plist-get result :status) 'error))
        (should (plist-get result :operation-id))
        (should (plist-member result :stage))
        (should (equal (plist-get result :range) '(1 . 6)))
        (should (eq (plist-get result :rollback-applied) t))
        (should (plist-get result :original-condition)))
      (should (equal (tp-managed-tests--raw-intervals) before)))))

(ert-deftest tp-managed-test-string-transaction-restores-every-property-run ()
  "String rollback restores characters and every distinct property run."
  (tp-managed-tests--with-clean
    (let ((text (copy-sequence "abcdef")))
      (put-text-property 0 2 'face 'bold text)
      (put-text-property 2 4 'face 'italic text)
      (put-text-property 4 6 'help-echo "tail" text)
      (let ((before (copy-sequence text)))
        (should-error
         (tp-layer-transaction
          0 6 text
          (lambda ()
            (set-text-properties 0 6 '(face underline) text)
            (signal 'error '("rollback string")))))
        (should (equal-including-properties text before))))))

(ert-deftest tp-managed-test-fixed-seed-stack-state-machine ()
  "Fixed seeds preserve public stack order across varied operations."
  (dolist (seed '(1 7 42 747555))
    (tp-managed-tests--with-clean
      (insert "x")
      (dolist (name '(stage4-sm-a stage4-sm-b stage4-sm-c))
        (eval `(define-tp ,name () '(face bold))))
      (let ((state seed)
            (names '(stage4-sm-a stage4-sm-b stage4-sm-c))
            model)
        (dotimes (_ 40)
          (setq state (mod (+ (* state 1103515245) 12345) 2147483648))
          (pcase (% state 4)
            (0
             (let ((name (nth (% (/ state 4) 3) names)))
               (unless (memq name model)
                 (tp-push-layer 1 2 name)
                 (push name model))))
            (1
             (when model
               (tp-pop-layer 1 2)
               (setq model (cdr model))))
            (2
             (when (cdr model)
               (tp-move-layer 1 2 0 -1)
               (setq model (append (cdr model) (list (car model))))))
            (3
             (when model
               (tp-hide-layer 1 2 (car model))
               (tp-show-layer 1 2 (car model)))))
          (should (equal (mapcar #'car (tp-layer-stack-at 1)) model)))))))

(ert-deftest tp-managed-test-theme-generation-diagnostics-increments-on-theme-hooks ()
  "Theme lifecycle diagnostics record generation and hook source."
  (tp-managed-tests--with-clean
    (insert "abcd")
    (define-tp stage4-theme () '(face (:foreground "red")))
    (tp-put-layer 1 4 'stage4-theme 0)
    (let* ((before (tp-managed-tests--managed-diagnostics))
           (before-theme (plist-get before :theme))
           (before-generation (plist-get before-theme :generation)))
      (should (integerp before-generation))
      (enable-theme 'user)
      (let* ((after-enable (tp-managed-tests--managed-diagnostics))
             (theme (plist-get after-enable :theme)))
        (should (> (plist-get theme :generation) before-generation))
        (should (eq (plist-get theme :last-hook-source) 'enable-theme))
        (should (member (plist-get theme :refresh-mode)
                        '(:dependency-targeted :conservative)))
        (should (plist-get theme :refreshed-ranges)))
      (disable-theme 'user)
      (let* ((after-disable (tp-managed-tests--managed-diagnostics))
             (theme (plist-get after-disable :theme)))
        (should (eq (plist-get theme :last-hook-source) 'disable-theme))))))

(provide 'tp-managed-tests)
;;; tp-managed-tests.el ends here