0d35358e05
Replace the legacy managed layer renderer with one independent retained/reactive text runtime. TP now owns exact dependencies, stable objects, marker-backed mounts, property contribution composition, atomic publication, rollback, and direct text-property facades without ECSS or Ebox dependencies.\n\nBREAKING CHANGE: remove tp-render, tp-stack, scan-driven managed layers, inline runtime metadata, TP-owned CSS cascade APIs, and dollar-variable declarations.\n\nVerified: 290/290 ERT, shuffled 290/290 (seed 20260806), 8/8 doctests, WERROR compile-all, checkdoc, package-lint, diff-check, and isolated TP-only load.
248 lines
13 KiB
EmacsLisp
248 lines
13 KiB
EmacsLisp
;;; 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
|