;;; tp-examples-tests.el --- Tests for public TP examples -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Geekinney ;; SPDX-License-Identifier: GPL-3.0-or-later ;;; Commentary: ;; Exercises the new examples in `examples/` through public TP entry points. ;;; Code: (require 'ert) (require 'tp) (require 'static-properties) (require 'reactive-status) (require 'retained-dashboard) (require 'diagnostic-decoration) (defmacro tp-examples-tests--with-temp-buffer (name &rest body) "Run BODY in a temporary isolated buffer. NAME is the buffer name to create." (declare (indent 1) (debug t)) `(let ((buffer (generate-new-buffer ,name))) (unwind-protect (progn ,@body) (when (buffer-live-p buffer) (kill-buffer buffer))))) (defun tp-examples-tests--buffer-substring (buffer) "Return full buffer text from BUFFER as plain string." (with-current-buffer buffer (buffer-substring-no-properties (point-min) (point-max)))) (defun tp-examples-tests--label-property (state label property) "Return PROPERTY at LABEL start in STATE buffer." (let ((buffer (plist-get state :buffer))) (with-current-buffer buffer (save-excursion (goto-char (point-min)) (when (search-forward label nil t) (get-text-property (match-beginning 0) property)))))) (ert-deftest tp-examples-test-static-properties-direct-output-observable () (let ((styled (tp-example-static-properties-format-title "Release"))) (should (equal (substring-no-properties styled) (format "%-28s" "Release"))) (should (equal (get-text-property 0 'face styled) '((:weight bold) (:foreground "white" :background "#3c4656")))) (should (equal (get-text-property 0 'keymap styled) tp-example-static-properties-keymap)) (should (eq (get-text-property 0 'help-echo styled) #'tp-example-static-properties-help)) (should (plist-member (text-properties-at 0 styled) 'mouse-face)) (should-not (get-text-property 0 'mouse-face styled))) (tp-examples-tests--with-temp-buffer " *tp-static-range*" (with-current-buffer buffer (insert "hello world") (should (equal (tp-example-static-properties-mark-range buffer 1 6 "#dff0") '(1 . 6))) (should (equal (tp-at 1 'face buffer) '(:background "#dff0"))) (should (equal (tp-at 1 'help-echo buffer) "Static range marker"))))) (ert-deftest tp-examples-test-reactive-status-noop-and-sparse-dependency () (tp-examples-tests--with-temp-buffer " *tp-reactive-status*" (let* ((state (tp-example-reactive-status-mount buffer)) (surface (plist-get state :surface))) (unwind-protect (progn (should (equal (tp-example-reactive-status-color state) "ForestGreen")) (should (equal (tp-at 1 'help-echo buffer) "status=ready")) (tp-example-reactive-status-clear-reactive-counters) (let ((before-revision (tp-surface-revision surface))) (tp-example-reactive-status-poke state 10) (should (= (tp-surface-revision surface) before-revision)) (should (= (plist-get (tp-reactive-counters) :invalidated) 0)) (should (= (plist-get (tp-reactive-counters) :recomputed) 0)) (tp-example-reactive-status-set state 'error) (should (= (tp-surface-revision surface) (+ before-revision 1))) (should (equal (tp-example-reactive-status-color state) "IndianRed")) (should (equal (tp-at 1 'help-echo buffer) "status=error")) (should (= (plist-get (tp-example-reactive-status-watch-report state) :new-revision) (+ before-revision 1))) (tp-example-reactive-status-clear-reactive-counters) (tp-example-reactive-status-set state 'error) (should (= (tp-surface-revision surface) (+ before-revision 1))) (should (= (plist-get (tp-reactive-counters) :invalidated) 0)) (should (= (plist-get (tp-reactive-counters) :recomputed) 0)) (tp-example-reactive-status-poke state 11) (should (= (tp-surface-revision surface) (+ before-revision 1))) (should (= (plist-get (tp-reactive-counters) :invalidated) 0)) (should (= (plist-get (tp-reactive-counters) :recomputed) 0)))) (tp-example-reactive-status-dispose state) (should-not (tp-surface-live-p surface)) (should-not (tp-surface-live-p (plist-get state :surface))) (should-not (tp-signal-live-p (plist-get state :status))) (should-not (tp-signal-live-p (plist-get state :noise))))))) (ert-deftest tp-examples-test-reactive-content-dependencies-and-batch () (tp-examples-tests--with-temp-buffer " *tp-reactive-content*" (let* ((state (tp-example-reactive-content-mount buffer)) (surface (plist-get state :surface))) (unwind-protect (progn (should (equal (tp-example-reactive-content-text state) "primary:ready")) (let ((revision (tp-surface-revision surface))) (tp-reactive-reset-counters) (tp-example-reactive-content-set-fallback state "standby") (should (= (tp-surface-revision surface) revision)) (should (= (plist-get (tp-reactive-counters) :invalidated) 0))) (let ((revision (tp-surface-revision surface))) (tp-example-reactive-content-batch-primary state (mapcar (lambda (number) (format "step-%d" number)) (number-sequence 1 100))) (should (= (tp-surface-revision surface) (1+ revision))) (should (equal (tp-example-reactive-content-text state) "primary:step-100"))) (tp-example-reactive-content-set-enabled state nil) (should (equal (tp-example-reactive-content-text state) "fallback:standby")) (let ((revision (tp-surface-revision surface))) (tp-example-reactive-content-set-primary state "ignored") (should (= (tp-surface-revision surface) revision))) (tp-example-reactive-content-set-fallback state "offline") (should (equal (tp-example-reactive-content-text state) "fallback:offline"))) (tp-example-reactive-content-dispose state) (should-not (tp-surface-live-p surface)) (dolist (key '(:enabled :primary :fallback)) (should-not (tp-signal-live-p (plist-get state key)))))))) (ert-deftest tp-examples-test-retained-dashboard-identity-theme-and-failure-recovery () (tp-examples-tests--with-temp-buffer " *tp-retained-dashboard*" (let* ((dashboard (tp-example-retained-dashboard-mount buffer)) (surface (plist-get dashboard :surface)) (alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha)) (gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma)) (report-before (tp-example-retained-dashboard-report dashboard))) (unwind-protect (progn (should (eq alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha))) (should (eq gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma))) (should (consp (tp-examples-tests--label-property dashboard " Alpha " 'keymap))) (should (equal (tp-examples-tests--label-property dashboard " Alpha " 'button) "entry:alpha")) (let* ((theme-report (tp-example-retained-dashboard-set-theme dashboard 'dark)) (theme-revision (plist-get theme-report :new-revision))) (should (= theme-revision (+ (plist-get report-before :new-revision) 1))) (should (equal (tp-examples-tests--label-property dashboard " Alpha " 'face) '(:weight bold :foreground "#83a598")))) (let* ((revision-before-update (tp-surface-revision surface)) (update-report (tp-example-retained-dashboard-update dashboard '((:id gamma :label "Gamma") (:id alpha :label "Alpha" :active t) (:id delta :label "Delta"))))) (should (eq gamma-handle (tp-example-retained-dashboard-entry-handle dashboard 'gamma))) (should (eq alpha-first-handle (tp-example-retained-dashboard-entry-handle dashboard 'alpha))) (should-not (tp-example-retained-dashboard-entry-handle dashboard 'beta)) (should (string-match-p "Gamma" (tp-examples-tests--buffer-substring buffer))) (should (string-match-p "Delta" (tp-examples-tests--buffer-substring buffer))) (should (> (plist-get update-report :new-revision) revision-before-update))) (let ((committed-text (tp-examples-tests--buffer-substring buffer)) (committed-revision (tp-surface-revision surface))) (should-error (tp-example-retained-dashboard-update dashboard '((:id forced :label "Boom" :force-failure t)))) (should (equal (tp-examples-tests--buffer-substring buffer) committed-text)) (should (= (tp-surface-revision surface) committed-revision)) (should (eq (tp-example-retained-dashboard-entry-handle dashboard 'alpha) alpha-first-handle)))) (let ((report (tp-example-retained-dashboard-remove dashboard))) (should (plist-get report :unmounted)) (should-not (tp-surface-live-p surface)) (should-not (tp-signal-live-p (plist-get (plist-get dashboard :state) :theme)))))))) (ert-deftest tp-examples-test-diagnostic-decoration-conflict-rebase-cleanup () (tp-examples-tests--with-temp-buffer " *tp-diagnostic-decoration*" (let* ((state (tp-example-diagnostic-decoration-mount buffer)) (surface (plist-get state :surface))) (unwind-protect (progn (let ((range-before (tp-example-diagnostic-decoration-range state))) (should (equal range-before '(2 . 6))) (let ((warn-report (tp-example-diagnostic-decoration-set-mode state 'warn))) (should (> (plist-get warn-report :new-revision) 0)) (should (equal (tp-at (car range-before) 'face buffer) '(:foreground "DarkOrange")))) (tp-example-diagnostic-decoration-insert-host-text state 1 "[") (should (equal (tp-example-diagnostic-decoration-range state) (cons (+ (car range-before) 1) (+ (cdr range-before) 1)))) (tp-example-diagnostic-decoration-delete-host-range state 1 2) (should (equal (tp-example-diagnostic-decoration-range state) range-before)) (tp-example-diagnostic-decoration-repaint-range state '(face (:foreground "Blue") help-echo "host override")) (let ((revision (tp-surface-revision surface))) (should-error (tp-example-diagnostic-decoration-set-mode state 'busy) :type 'tp-property-conflict) (should (= (tp-surface-revision surface) revision)) (should (eq (tp-signal-peek (plist-get state :mode-signal)) 'warn)) (should (equal (tp-at (car range-before) 'face buffer) '(:foreground "Blue")))) (tp-example-diagnostic-decoration-rebase state) (tp-example-diagnostic-decoration-set-mode state 'busy) (should (equal (tp-at (car range-before) 'face buffer) '(:foreground "Purple"))) (tp-example-diagnostic-decoration-repaint-range state '(face (:foreground "Blue") help-echo "host override")))) (let ((unmount (tp-example-diagnostic-decoration-unmount state))) (should (plist-get unmount :unmounted)) (should (consp (plist-get unmount :property-conflicts))) (should (buffer-live-p buffer)) (should-not (tp-range-anchor-live-p (plist-get state :anchor))) (should-not (tp-signal-live-p (plist-get state :mode-signal))) (should (equal (tp-at 2 'face buffer) '(:foreground "Blue")))))))) ;;; tp-examples-tests.el ends here