972b6d4e4c
Add canonical query semantics, managed metadata and transactions, overlay-aware lookup, reproducible benchmarks, and synchronized API documentation.
304 lines
13 KiB
EmacsLisp
304 lines
13 KiB
EmacsLisp
;;; 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
|