;;; ebox-state-contract-tests.el --- M2a state ownership contracts -*- lexical-binding: t; -*- ;;; Code: (require 'ert) (require 'cl-lib) (require 'ebox) (require 'ebox-state-contract) (require 'ebox-fixtures) (defconst ebox-state-contract-test--plan-expectations '((runtime-generation-indexes (:source-index ebox-source-index/records ebox-source-index/handle-records ebox-source-index/host-ref-table :root-node :node-table :parent-table :runtime-type-count-table :range-ref-table :selector-id-table :selector-class-table :selector-type-table ebox--region-line-index ebox--render-source-index) generation-fact ebox candidate-construction-only immutable-generation-token discard-candidate source-and-runtime-index-rebuild generation-replacement) (region-generation-indexes (:region-id-set :region-node-table :region-box-count-table :region-box-table :layout-snapshots) generation-fact ebox candidate-layout-materialization-only immutable-generation-token discard-candidate layout-and-region-index-rebuild generation-replacement) (scroll-membership (:scroll-region-ids) generation-fact ebox candidate-layout-materialization-only immutable-generation-token discard-candidate layout-scroll-membership-rebuild generation-replacement) (scroll-runtime-authority (:scroll-state-table :scroll-offset :scroll-window ebox--scroll-global-state ebox--smooth-scroll-state-table ebox--scroll-idle-prefetch-timers ebox--scroll-idle-prefetch-inhibited-buffers) generation-bound-mutable-authority ebox-scroll stable-scroll-id-and-generation-token required participant-journal-restores-prior-authority not-rebuildable-from-cache cancel-timers-and-retire-generation) (native-runtime-authority (:native-sync-session :native-sync-pending :native-session ebox-native-reflow-preparation ebox-native-reflow-session ebox-native-reflow-preparation/ready-timer) generation-bound-mutable-authority ebox-native native-candidate-confirm-or-abort required abort-candidate-and-keep-confirmed-session not-rebuildable-from-cache release-losing-session) (runtime-prewarm-authority (ebox--deferred-render-gc-state ebox--deferred-render-gc-timer ebox--deferred-render-gc-depth ebox--deferred-render-gc-generation ebox--render-burst-records ebox--render-burst-stack ebox--reflow-cache-prewarm-timers ebox--runtime-prewarm-jobs ebox--runtime-prewarm-timers) generation-bound-mutable-authority ebox-runtime-scheduler schedule-cancel-and-revision-validate buffer-and-runtime-revision cancel-candidate-work reschedule-from-committed-generation cancel-timers-jobs-and-gc-lease) (incremental-batch-authority (ebox-incremental--batch-table) generation-bound-mutable-authority ebox-incremental batch-begin-record-flush-or-abort captured-base-generation discard-pending-batch batch-begin-from-committed-generation batch-end-or-buffer-kill) (layout-context-port-authority (ebox--layout-context-port) generation-bound-mutable-authority ebox-render-context facade-install-and-dynamic-bind one-port-captured-per-render-call dynamic-binding-unwind reinstall-default-surface-port package-reload-or-binding-unwind) (identity-allocation-authority (ebox--region-id-counter ebox--runtime-node-id-counter) generation-bound-mutable-authority ebox-identity next-region-or-runtime-node-id allocated-identity-enters-one-candidate allocator-gaps-are-non-authoritative monotonic-next-allocation process-lifetime-test-reset-only) (buffer-surface-runtime-authority (ebox-surface--buffer-surface ebox-surface--buffer-observer ebox-surface--tp-observer ebox-surface--observation-contexts ebox-surface--context-signals) generation-bound-mutable-authority ebox-surface mount-observe-publish-and-unmount buffer-surface-and-publication-revision restore-prior-surface-signals-and-observer-bridge not-rebuildable-from-cache remove-observers-cancel-contexts-and-unmount) (tp-client-state-custody (tp-surface-client-state) tp-storage-custody tp opaque-ebox-generation-correlation-only opaque-correlation tp-restores-client-state ebox-generation-remains-source-of-truth tp-surface-unmount) (buffer-render-state-mirror (ebox--buffer-render-state-table) compatibility-mirror ebox-compatibility project-from-committed-generation committed-generation-token participant-restores-prior-projection project-buffer-mirror-from-committed-states remove-buffer-entry) (region-box-lookup-mirror (ebox--region-box-table) compatibility-mirror ebox-compatibility project-from-committed-generation committed-generation-token participant-restores-prior-projection project-region-mirror-from-generation-indexes remove-retired-generation-entries) (font-cache (ebox-font--cache) disposable-cache ebox-font cache-fill-and-evict display-capability-signature discard resolve-font-fact-again ebox-font-clear-cache) (native-hover-face-cache (ebox-interaction--hover-face-cache) disposable-cache ebox-interaction weak-cache-fill hover-owner-and-computed-paint discard-unreferenced-candidates reproject-owner-native-hover-face garbage-collect-unreferenced-faces) (derived-caches (ebox--char-width-cache ebox--face-height-width-cache ebox--display-signature-cache ebox--render-cache-signature-cache ebox-style--property-index) disposable-cache ebox-cache cache-fill-and-evict cache-key-or-display-signature discard recompute-with-identical-semantic-result bounded-eviction-or-clear)) "M2a section 7.2 minimum lifecycle expectations used by the E1 gate.") (defun ebox-state-contract-test--store-name-p (symbol) "Return non-nil when SYMBOL has a retained-container source name." (and (symbolp symbol) (string-match-p (concat "\\(?:-table\\|-cache\\|-index\\|-indexes\\|-registry\\|-history" "\\|-session\\|-jobs\\|-timer\\|-timers\\|-generations\\|-states" "\\|-contexts\\|-signals\\|-records\\|-stack\\|-surface\\|-observers?" "\\|-buffers\\)\\'") (symbol-name symbol)))) (defun ebox-state-contract-test--container-constructor-p (form) "Return non-nil when FORM directly constructs a mutable container." (memq (car-safe form) '(make-hash-table make-vector vector list cons copy-sequence make-ring make-sparse-keymap make-keymap))) (defun ebox-state-contract-test--read-forms (file) "Read every top-level form from FILE." (with-temp-buffer (insert-file-contents file) (let (forms form) (condition-case nil (while t (setq form (read (current-buffer))) (push form forms)) (end-of-file nil)) (nreverse forms)))) (defun ebox-state-contract-test--walk-form (form function) "Call FUNCTION for FORM and every nested cons or vector element." (funcall function form) (cond ((consp form) (ebox-state-contract-test--walk-form (car form) function) (ebox-state-contract-test--walk-form (cdr form) function)) ((vectorp form) (mapc (lambda (item) (ebox-state-contract-test--walk-form item function)) form)))) (defun ebox-state-contract-test--declared-globals (forms) "Return globals declared by top-level FORMS." (let (globals) (dolist (form forms) (when (and (memq (car-safe form) '(defvar defconst defvar-local)) (symbolp (cadr form))) (push (cadr form) globals))) (delete-dups globals))) (defun ebox-state-contract-test--form-evidence (form declared-globals) "Return typed global-state evidence found inside FORM. Each result is a (SYMBOL . TYPE) pair. Scalar evidence remains visible for exclusion freshness, but only retained/container evidence is coverage-gated." (let (evidence) (ebox-state-contract-test--walk-form form (lambda (nested) (pcase (car-safe nested) ((or 'let 'let*) (dolist (binding (cadr nested)) (when (and (consp binding) (memq (car binding) declared-globals)) (push (cons (car binding) (if (ebox-state-contract-test--container-constructor-p (cadr binding)) 'dynamic-container-binding 'dynamic-scalar-binding)) evidence)))) ((or 'setq 'setq-default 'setq-local) (let ((pairs (cdr nested))) (while pairs (when (memq (car pairs) declared-globals) (push (cons (car pairs) (if (ebox-state-contract-test--container-constructor-p (cadr pairs)) 'container-assignment 'scalar-assignment)) evidence)) (setq pairs (cddr pairs))))) ((or 'cl-incf 'cl-decf) (when (memq (cadr nested) declared-globals) (push (cons (cadr nested) 'scalar-mutation) evidence))) ('pop (when (memq (cadr nested) declared-globals) (push (cons (cadr nested) 'container-mutation) evidence))) ('push (when (memq (caddr nested) declared-globals) (push (cons (caddr nested) 'container-mutation) evidence))) ('cl-pushnew (when (memq (caddr nested) declared-globals) (push (cons (caddr nested) 'container-mutation) evidence))) ('add-to-list (let ((symbol (cadr nested))) (when (and (eq (car-safe symbol) 'quote) (memq (cadr symbol) declared-globals)) (push (cons (cadr symbol) 'container-mutation) evidence)))) ('puthash (when (memq (nth 3 nested) declared-globals) (push (cons (nth 3 nested) 'container-mutation) evidence))) ('remhash (when (memq (nth 2 nested) declared-globals) (push (cons (nth 2 nested) 'container-mutation) evidence))) ('clrhash (when (memq (cadr nested) declared-globals) (push (cons (cadr nested) 'container-mutation) evidence))) ('aset (when (memq (cadr nested) declared-globals) (push (cons (cadr nested) 'container-mutation) evidence))) ('setf (let ((pairs (cdr nested))) (while pairs (when (memq (car pairs) declared-globals) (push (cons (car pairs) (if (ebox-state-contract-test--container-constructor-p (cadr pairs)) 'container-assignment 'scalar-assignment)) evidence)) (setq pairs (cddr pairs)))))))) (delete-dups evidence))) (defconst ebox-state-contract-test--retained-evidence-types '(buffer-local-declaration container-initializer store-name dynamic-container-binding container-assignment container-mutation) "Evidence types that require retained-state classification or exclusion.") (defun ebox-state-contract-test--source-state-evidence () "Return typed source-backed global-state evidence, grouped by symbol." (let* ((sources (delete-dups (copy-sequence ebox--compile-sources))) (entries (mapcar (lambda (source) (cons source (ebox-state-contract-test--read-forms source))) sources)) (declared (delete-dups (cl-mapcan (lambda (entry) (ebox-state-contract-test--declared-globals (cdr entry))) entries))) (by-symbol (make-hash-table :test #'eq))) (cl-labels ((record (symbol source type) (when (memq symbol declared) (let ((entry (or (gethash symbol by-symbol) (list :symbol symbol :files nil :evidence-types nil)))) (cl-pushnew source (plist-get entry :files) :test #'equal) (cl-pushnew type (plist-get entry :evidence-types)) (puthash symbol entry by-symbol))))) (dolist (entry entries) (let ((source (car entry))) (dolist (form (cdr entry)) (when (and (memq (car-safe form) '(defvar defconst defvar-local)) (symbolp (cadr form))) (let ((symbol (cadr form))) (when (eq (car form) 'defvar-local) (record symbol source 'buffer-local-declaration)) (when (ebox-state-contract-test--store-name-p symbol) (record symbol source 'store-name)) (when (ebox-state-contract-test--container-constructor-p (caddr form)) (record symbol source 'container-initializer)))) (dolist (item (ebox-state-contract-test--form-evidence form declared)) (record (car item) source (cdr item))))))) (let (result) (maphash (lambda (_symbol entry) (setf (plist-get entry :files) (sort (plist-get entry :files) #'string<)) (setf (plist-get entry :evidence-types) (sort (plist-get entry :evidence-types) (lambda (left right) (string< (symbol-name left) (symbol-name right))))) (push entry result)) by-symbol) (sort result (lambda (left right) (string< (symbol-name (plist-get left :symbol)) (symbol-name (plist-get right :symbol)))))))) (defun ebox-state-contract-test--source-store-candidates () "Return retained/container candidates with typed source evidence." (cl-remove-if-not (lambda (entry) (cl-intersection (plist-get entry :evidence-types) ebox-state-contract-test--retained-evidence-types)) (ebox-state-contract-test--source-state-evidence))) (ert-deftest ebox-state-contract-inventory-is-complete-and-closed () "Every retained-state family has one complete closed classification." (let* ((inventory (ebox-state-contract-validate)) (ids (mapcar (lambda (record) (plist-get record :id)) inventory)) (storage (cl-mapcan (lambda (record) (cl-remove-if-not (lambda (symbol) (and (symbolp symbol) (not (keywordp symbol)))) (copy-sequence (plist-get record :storage)))) inventory))) (should (= (length ids) (length (delete-dups (copy-sequence ids))))) (should (= (length storage) (length (delete-dups (copy-sequence storage))))) (dolist (record inventory) (dolist (field ebox-state-contract-required-fields) (should (plist-get record field))) (should (memq (plist-get record :category) ebox-state-contract-categories))) (dolist (expected ebox-state-contract-test--plan-expectations) (should (memq (car expected) ids))))) (ert-deftest ebox-state-contract-validator-rejects-duplicate-storage () "One source storage identity cannot belong to two inventory records." (let* ((inventory (ebox-state-contract-inventory)) (duplicate 'ebox--render-source-index) (second (cadr inventory)) (ebox-state-contract--inventory (cons (car inventory) (cons (plist-put second :storage (cons duplicate (plist-get second :storage))) (cddr inventory))))) (should-error (ebox-state-contract-validate) :type 'ebox-state-contract-error))) (ert-deftest ebox-state-contract-inventory-covers-plan-table-minimums () "Every plan-named storage family keeps its required lifecycle classification." (dolist (expected ebox-state-contract-test--plan-expectations) (let ((record (ebox-state-contract-record (nth 0 expected)))) (should (cl-subsetp (nth 1 expected) (plist-get record :storage) :test #'equal)) (should (eq (plist-get record :category) (nth 2 expected))) (should (eq (plist-get record :owner) (nth 3 expected))) (should (eq (plist-get record :mutation-api) (nth 4 expected))) (should (eq (plist-get record :generation-binding) (nth 5 expected))) (should (eq (plist-get record :rollback) (nth 6 expected))) (should (eq (plist-get record :rebuild-proof) (nth 7 expected))) (should (eq (plist-get record :cleanup) (nth 8 expected)))))) (ert-deftest ebox-state-contract-source-scan-is-fail-closed () "Every source-declared retained global is classified or proven scalar." (let* ((classified (ebox-state-contract-storage-symbols)) (excluded (mapcar (lambda (entry) (plist-get entry :symbol)) ebox-state-contract-source-scan-exclusions)) (evidence (ebox-state-contract-test--source-state-evidence)) (evidence-symbols (mapcar (lambda (entry) (plist-get entry :symbol)) evidence)) (candidates (ebox-state-contract-test--source-store-candidates))) (should (> (length candidates) 50)) (should-not (cl-intersection classified excluded)) (should (= (length excluded) (length (delete-dups (copy-sequence excluded))))) (dolist (entry ebox-state-contract-source-scan-exclusions) (should (plist-get entry :symbol)) (should (plist-get entry :reason)) (should (plist-get entry :evidence)) (should (memq (plist-get entry :symbol) evidence-symbols))) (dolist (candidate candidates) (should (plist-get candidate :files)) (should (plist-get candidate :evidence-types)) (should (or (memq (plist-get candidate :symbol) classified) (memq (plist-get candidate :symbol) excluded)))))) (ert-deftest ebox-state-contract-source-scan-sees-boundary-sentinels () "The scanner sees buffer-local authority and transient render containers." (let ((symbols (mapcar (lambda (entry) (plist-get entry :symbol)) (ebox-state-contract-test--source-store-candidates)))) (dolist (symbol '(ebox-surface--buffer-surface ebox-surface--observation-contexts ebox-surface--context-signals ebox--render-source-generations ebox--render-source-states)) (should (memq symbol symbols))))) (ert-deftest ebox-state-contract-inventory-is-detached () "Callers cannot mutate the retained package inventory." (let ((copy (ebox-state-contract-inventory))) (setf (plist-get (car copy) :category) 'disposable-cache) (should (eq (plist-get (ebox-state-contract-record 'runtime-generation-indexes) :category) 'generation-fact)))) (ert-deftest ebox-state-contract-never-classifies-live-authority-as-cache () "Cleanup-sensitive handles retain generation-bound mutable authority." (dolist (id '(scroll-runtime-authority native-runtime-authority runtime-prewarm-authority viewport-event-authority incremental-batch-authority layout-context-port-authority identity-allocation-authority buffer-surface-runtime-authority)) (let ((record (ebox-state-contract-record id))) (should (eq (plist-get record :category) 'generation-bound-mutable-authority)) (should (plist-get record :generation-binding)) (should (plist-get record :cleanup)))) (dolist (id '(scroll-runtime-authority native-runtime-authority)) (should (eq (plist-get (ebox-state-contract-record id) :rebuild-proof) 'not-rebuildable-from-cache)))) (ert-deftest ebox-state-contract-classifies-buffer-local-surface-authority () "Mounted surfaces, signals, and observer state remain explicit authority." (let ((record (ebox-state-contract-record 'buffer-surface-runtime-authority))) (dolist (symbol '(ebox-surface--buffer-surface ebox-surface--buffer-observer ebox-surface--tp-observer ebox-surface--observation-contexts ebox-surface--context-signals)) (should (memq symbol (plist-get record :storage)))) (should (eq (plist-get record :category) 'generation-bound-mutable-authority)) (should (eq (plist-get record :rebuild-proof) 'not-rebuildable-from-cache)))) (ert-deftest ebox-state-contract-excludes-dynamic-render-source-containers () "Transient old/candidate render inputs are not mislabeled as retained facts." (dolist (symbol '(ebox--render-source-generations ebox--render-source-states)) (should-not (memq symbol (ebox-state-contract-storage-symbols))) (let ((entry (cl-find symbol ebox-state-contract-source-scan-exclusions :key (lambda (item) (plist-get item :symbol))))) (should entry) (should (eq (plist-get entry :reason) 'dynamically-bound-render-proof-input))))) (ert-deftest ebox-state-contract-classifies-font-and-prewarm-stores-explicitly () "Font cache and cleanup-sensitive prewarm stores cannot hide in broad prose." (let ((font (ebox-state-contract-record 'font-cache)) (prewarm (ebox-state-contract-record 'runtime-prewarm-authority))) (should (equal (plist-get font :storage) '(ebox-font--cache))) (should (eq (plist-get font :category) 'disposable-cache)) (dolist (symbol '(ebox--runtime-prewarm-jobs ebox--runtime-prewarm-timers ebox--reflow-cache-prewarm-timers ebox--deferred-render-gc-state ebox--deferred-render-gc-timer ebox--deferred-render-gc-depth ebox--deferred-render-gc-generation ebox--render-burst-records ebox--render-burst-stack)) (should (memq symbol (plist-get prewarm :storage)))) (should (eq (plist-get prewarm :category) 'generation-bound-mutable-authority)))) (ert-deftest ebox-state-contract-excludes-native-compile-scratch-from-authority () "Compile-local indexes are not mislabeled as native session authority." (let ((authority-storage (plist-get (ebox-state-contract-record 'native-runtime-authority) :storage))) (dolist (symbol '(ebox-native-reflow--compile-property-template-ids ebox-native-reflow--compile-property-template-index ebox-native-reflow--compile-style-index)) (should-not (memq symbol authority-storage)) (let ((exclusion (cl-find symbol ebox-state-contract-source-scan-exclusions :key (lambda (entry) (plist-get entry :symbol))))) (should exclusion) (should (eq (plist-get exclusion :reason) 'dynamically-bound-compile-local-scratch)))))) (ert-deftest ebox-state-contract-tp-custody-is-opaque () "The inventory separates current whole-state custody from its M2a target." (let ((record (ebox-state-contract-record 'tp-client-state-custody))) (should (eq (plist-get record :owner) 'tp)) (should (eq (plist-get record :current-contract) 'entire-ebox-state-plist)) (should (eq (plist-get record :target-contract) 'opaque-generation-correlation-only)) (should (eq (plist-get record :mutation-api) 'opaque-ebox-generation-correlation-only)) (should (eq (plist-get record :rebuild-proof) 'ebox-generation-remains-source-of-truth)))) (ert-deftest ebox-state-contract-rebuilds-current-compatibility-mirrors () "Committed client state rebuilds the current buffer and region mirrors." (let ((buffer (generate-new-buffer " *ebox-m2a-e1-mirror*"))) (unwind-protect (let* ((_rendered (ebox-render-to-buffer buffer (ebox-test-column (ebox-test-box :key 'first (ebox-test-text "first")) (ebox-test-box :key 'second (ebox-test-text "second"))))) (surface (ebox-surface--live-buffer-surface buffer)) (state (tp-surface-client-state surface)) (before-text (with-current-buffer buffer (buffer-substring (point-min) (point-max)))) (before-revision (tp-surface-revision surface)) (entries (list (cons buffer state))) (rebuilt (ebox-state-contract-rebuild-compatibility-mirrors entries)) (report (ebox-state-contract-probe-compatibility-mirrors entries ebox--buffer-render-state-table ebox--region-box-table))) (should (plist-get report :consistent-p)) (should-not (plist-get report :buffer-differences)) (should-not (plist-get report :region-differences)) (should-not (eq (plist-get rebuilt :buffer-table) ebox--buffer-render-state-table)) (should-not (eq (plist-get rebuilt :region-table) ebox--region-box-table)) (should (eq (gethash buffer (plist-get rebuilt :buffer-table)) state)) (should (equal (hash-table-count (plist-get rebuilt :region-table)) (hash-table-count (plist-get state :region-box-table)))) (should (eq (tp-surface-client-state surface) state)) (should (= (tp-surface-revision surface) before-revision)) (should (equal (with-current-buffer buffer (buffer-substring (point-min) (point-max))) before-text))) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest ebox-state-contract-probe-detects-mirror-drift-without-mutation () "The read-only probe reports stale compatibility entries." (let* ((buffer (generate-new-buffer " *ebox-m2a-e1-drift*")) (region-id 'ebox/m2a-e1-region) (box (list :node-id 'ebox/m2a-e1-box)) (regions (make-hash-table :test #'equal)) (state (list :region-box-table regions)) (entries (list (cons buffer state))) (buffer-mirror (make-hash-table :test #'eq)) (region-mirror (make-hash-table :test #'equal)) (stale (list :node-id 'stale))) (unwind-protect (progn (puthash region-id box regions) (puthash buffer state buffer-mirror) (puthash region-id stale region-mirror) (let ((report (ebox-state-contract-probe-compatibility-mirrors entries buffer-mirror region-mirror))) (should-not (plist-get report :consistent-p)) (should (equal (plist-get report :region-differences) (list region-id))) (should (eq (gethash region-id region-mirror) stale)))) (when (buffer-live-p buffer) (kill-buffer buffer))))) (ert-deftest ebox-state-contract-rejects-cross-generation-region-collision () "Two committed generations cannot project different boxes for one region." (let ((first-buffer (generate-new-buffer " *ebox-m2a-e1-first*")) (second-buffer (generate-new-buffer " *ebox-m2a-e1-second*")) (first-regions (make-hash-table :test #'equal)) (second-regions (make-hash-table :test #'equal))) (unwind-protect (progn (puthash 'shared (list :node-id 'first) first-regions) (puthash 'shared (list :node-id 'second) second-regions) (should-error (ebox-state-contract-rebuild-compatibility-mirrors (list (cons first-buffer (list :region-box-table first-regions)) (cons second-buffer (list :region-box-table second-regions)))) :type 'ebox-state-contract-error)) (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) (when (buffer-live-p second-buffer) (kill-buffer second-buffer))))) (ert-deftest ebox-state-contract-probe-work-is-bounded-by-projection-size () "The E1 probe performs bounded table work and never traverses a node tree." (let (buffers entries) (unwind-protect (progn (dotimes (buffer-index 64) (let ((buffer (generate-new-buffer (format " *ebox-m2a-e1-perf-%d*" buffer-index))) (regions (make-hash-table :test #'equal))) (push buffer buffers) (dotimes (region-index 16) (puthash (cons buffer-index region-index) (list :node-id (cons buffer-index region-index)) regions)) (push (cons buffer (list :region-box-table regions)) entries))) (setq entries (nreverse entries)) (let* ((rebuilt (ebox-state-contract-rebuild-compatibility-mirrors entries)) (report (cl-letf (((symbol-function 'ebox-tree-map) (lambda (&rest _arguments) (error "E1 probe traversed the node tree")))) (ebox-state-contract-probe-compatibility-mirrors entries (plist-get rebuilt :buffer-table) (plist-get rebuilt :region-table))))) (should (plist-get report :consistent-p)) (should (= (plist-get report :entry-count) 64)) (should (= (plist-get report :projected-region-count) 1024)) (should (= (plist-get report :buffer-comparisons) 64)) (should (= (plist-get report :region-comparisons) 1024)))) (dolist (buffer buffers) (when (buffer-live-p buffer) (kill-buffer buffer)))))) (provide 'ebox-state-contract-tests) ;;; ebox-state-contract-tests.el ends here