From 525e6b38b73022c8ce0755a59b7beffb42c77a34 Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Mon, 31 Aug 2026 15:18:26 +0800 Subject: [PATCH] feat: close M0 core interaction contracts --- Makefile | 2 +- etaf-actions.el | 24 + etaf-compiler.el | 33 +- etaf-data.el | 79 +- etaf-renderer.el | 25 +- etaf-runtime.el | 745 +++++++---- etaf-view.el | 9 +- examples/etaf-counter-example.el | 138 +- examples/etaf-data-example.el | 213 +-- examples/etaf-resource-example.el | 138 +- scripts/etaf-m0a-inventory.el | 315 +++++ tests/etaf-interaction-contract-tests.el | 284 ++++ ...etaf-m0a-current-characterization-tests.el | 201 +++ tests/etaf-tests.el | 1143 +++++++++++------ .../etaf-m0a-condition-consumers.sexp | 20 + 15 files changed, 2423 insertions(+), 946 deletions(-) create mode 100644 scripts/etaf-m0a-inventory.el create mode 100644 tests/etaf-interaction-contract-tests.el create mode 100644 tests/etaf-m0a-current-characterization-tests.el create mode 100644 tests/fixtures/etaf-m0a-condition-consumers.sexp diff --git a/Makefile b/Makefile index 6951ffa..75e52e8 100644 --- a/Makefile +++ b/Makefile @@ -2,7 +2,7 @@ EMACS ?= emacs LOAD_PATH = -L . -L examples -L scripts -L ../ebox -L ../tp -L ../ecss SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el scripts/emacs-gui-verifier.el EXAMPLES = examples/etaf-counter-example.el examples/etaf-data-example.el examples/etaf-resource-example.el -TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el tests/etaf-gui-verifier-tests.el +TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-component-frontends-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el tests/etaf-gui-verifier-tests.el tests/etaf-m0a-current-characterization-tests.el tests/etaf-interaction-contract-tests.el tests/etaf-m0b-component-manifest-tests.el .PHONY: test compile load checkdoc docs-check check clean diff --git a/etaf-actions.el b/etaf-actions.el index 3d7c03c..fd6c929 100644 --- a/etaf-actions.el +++ b/etaf-actions.el @@ -31,12 +31,23 @@ (defvar etaf--action-registry (make-hash-table :test #'eq) "Action name -> `etaf-action-spec' table.") +(defvar etaf--allow-action-redefinition nil + "Non-nil only inside `etaf-action-redefine-run'.") + +(defun etaf--action-assert-definition-available (name) + "Signal when Action NAME cannot be defined in the current boundary." + (when (and (gethash name etaf--action-registry) + (not etaf--allow-action-redefinition)) + (signal 'etaf-action-error + (list (format "Duplicate ETAF Action: %S" name))))) + (defun etaf-action-register (name function) "Register FUNCTION as named Action NAME and return NAME." (etaf--assert-not-rendering 'register-action) (unless (and (symbolp name) (not (keywordp name)) (functionp function)) (signal 'etaf-action-error (list (format "Invalid Action registration: %S" name)))) + (etaf--action-assert-definition-available name) (puthash name (etaf--action-spec-create :name name :function function) etaf--action-registry) name) @@ -52,12 +63,25 @@ through `etaf-dispatch'." (let ((docstring (when (stringp (car body)) (pop body))) (function-symbol (intern (format "%s--etaf-action" name)))) `(progn + (etaf--action-assert-definition-available ',name) (defun ,function-symbol ,arguments ,(or docstring (format "Run ETAF Action `%s'." name)) ,@body) (etaf-action-register ',name #',function-symbol) ',name))) +;;;###autoload +(defun etaf-action-redefine-run (function) + "Run FUNCTION while allowing intentional Action redefinition. + +Normal duplicate registrations remain errors. This dynamic authoring +boundary replaces only the process-global name binding used by future +`etaf-dispatch' calls; it does not flush or rerender mounted Runtimes." + (unless (functionp function) + (signal 'wrong-type-argument (list 'functionp function))) + (let ((etaf--allow-action-redefinition t)) + (funcall function))) + ;;;###autoload (defun etaf-dispatch (action &rest arguments) "Dispatch named ACTION through the active Runtime with ARGUMENTS. diff --git a/etaf-compiler.el b/etaf-compiler.el index ecda4fa..aab3907 100644 --- a/etaf-compiler.el +++ b/etaf-compiler.el @@ -18,6 +18,7 @@ (defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/2") (defvar etaf-compiler--static-cache (make-hash-table :test #'equal)) +(defvar etaf-compiler--site-token-cache (make-hash-table :test #'equal)) (defvar etaf-compiler--registry-epoch 0) (defvar etaf-compiler--instantiate-count 0) (defvar etaf-compiler--last-blueprint nil) @@ -30,7 +31,22 @@ (defun etaf-compiler-clear-cache () "Clear all process-local compiled View materializations." (interactive) - (clrhash etaf-compiler--static-cache)) + (clrhash etaf-compiler--static-cache) + (clrhash etaf-compiler--site-token-cache)) + +(defun etaf-compiler--site-token (blueprint block) + "Return the stable opaque token for compiled BLOCK in BLUEPRINT." + (let* ((key (list (plist-get blueprint :id) + (plist-get block :path))) + (missing (make-symbol "etaf-compiled-site-token-missing")) + (token (gethash key etaf-compiler--site-token-cache missing))) + (if (not (eq token missing)) + token + (setq token (list 'etaf-compiled-site + (plist-get blueprint :id) + (plist-get block :path))) + (puthash key token etaf-compiler--site-token-cache) + token))) (defun etaf-compiler-statistics () "Return a read-only snapshot of compiler runtime statistics." @@ -313,12 +329,19 @@ cached (let ((value (pcase (plist-get block :kind) - ('literal (plist-get block :value)) + ;; The compiler's literal block is also used for a root string. + ;; Keep the same canonicalization as the non-compiled View path: + ;; a bare string is a Text View, while nil remains an empty + ;; structural value. + ('literal + (let ((literal (plist-get block :value))) + (if (and (stringp literal) + (= (length (plist-get block :path)) 1)) + (etaf--text-view-from-string literal) + literal))) ('expr (etaf--expr-create - :token (list 'etaf-compiled-site - (plist-get blueprint :id) - (plist-get block :path)) + :token (etaf-compiler--site-token blueprint block) :thunk (aref programs (plist-get block :hole)))) ((or 'branch 'keyed-list) (let ((program diff --git a/etaf-data.el b/etaf-data.el index 498796f..70bf9eb 100644 --- a/etaf-data.el +++ b/etaf-data.el @@ -49,7 +49,8 @@ CAPABILITIES is a plist. `:load' is required and receives QUERY, PAGE, and PAGE-SIZE. It must return a plist containing at least `:items', and may return `:total', `:page', and `:page-size'. `:mutate' is optional and receives OPERATION and PAYLOAD. `:dispose' is optional and runs when the owning -controller stops. `:provider' may name the source in observation reports and +controller stops. `:item-key' optionally returns stable selection identity +for one item. `:provider' may name the source in observation reports and defaults to `data'." (let ((load (plist-get capabilities :load)) (mutate (plist-get capabilities :mutate)) @@ -58,7 +59,8 @@ defaults to `data'." (unless (functionp load) (signal 'wrong-type-argument (list 'functionp load))) (dolist (entry `((:mutate . ,mutate) - (:dispose . ,dispose))) + (:dispose . ,dispose) + (:item-key . ,(plist-get capabilities :item-key)))) (when (and (cdr entry) (not (functionp (cdr entry)))) (signal 'wrong-type-argument (list 'functionp (cdr entry))))) (when (and (plist-member capabilities :provider) @@ -166,7 +168,8 @@ defaults to `data'." (cl-defun etaf-data-memory-source (items &key id-key name) "Create an in-memory Data source over ITEMS. -ID-KEY identifies records for `replace', `update', and `delete' mutations. +ID-KEY identifies records for `replace', `update', and `delete' mutations, +and is exposed to Data Controllers as the source's stable item identity. NAME optionally labels the source for diagnostics. Queries may be nil, a predicate, a search string, a plist, an alist, or an exact value. Supported mutations are `insert', `replace', `update', `delete', @@ -182,6 +185,9 @@ and `reset'." (etaf-data-source :name name :provider 'memory + :item-key (and id-key + (lambda (record) + (etaf-data--memory-record-id record id-key))) :load (lambda (query page page-size) (let* ((all (etaf-value records)) (filtered (funcall query-function query all))) @@ -245,6 +251,35 @@ use its result as `:initial-result' for `etaf-data-controller'." (etaf-data--normalize-result (etaf-data--source-load source query page page-size)))) +(defun etaf-data--item-identity (controller item) + "Return ITEM's selection identity in CONTROLLER." + (if-let* ((item-key (etaf-data--controller-item-key controller))) + (funcall item-key item) + item)) + +(defun etaf-data--ensure-selected-ref (controller identity) + "Return CONTROLLER's retained boolean selection ref for IDENTITY." + (let* ((refs (etaf-data--controller-selected-refs controller)) + (selected-ref (gethash identity refs))) + (or selected-ref + (let ((created + (etaf-ref + (not (null + (member identity + (etaf-data--controller-selection-snapshot + controller)))) + :name 'etaf-data-selected))) + (puthash identity created refs) + created)))) + +(defun etaf-data--prepare-selected-refs (controller items) + "Materialize CONTROLLER selection dependencies for ITEMS before render." + (dolist (identity (etaf-data--controller-selection-snapshot controller)) + (etaf-data--ensure-selected-ref controller identity)) + (dolist (item items) + (etaf-data--ensure-selected-ref + controller (etaf-data--item-identity controller item)))) + (defun etaf-data--apply-load-success (controller request-id result) "Publish successful RESULT for CONTROLLER when REQUEST-ID is current." (when (= request-id (etaf-data--controller-request-id controller)) @@ -253,6 +288,11 @@ use its result as `:initial-result' for `etaf-data-controller'." (unwind-protect (progn (setf (etaf-data--controller-auto-load-p controller) nil) + ;; ITEMS publication may synchronously schedule a DataGrid render. + ;; Materialize keyed selection dependencies first so render only + ;; reads retained reactive state. + (etaf-data--prepare-selected-refs + controller (plist-get normalized :items)) (setf (etaf-value (etaf-data--controller-items controller)) (plist-get normalized :items)) (setf (etaf-value (etaf-data--controller-total controller)) @@ -285,8 +325,8 @@ use its result as `:initial-result' for `etaf-data-controller'." QUERY, PAGE, PAGE-SIZE, result ITEMS, TOTAL, STATUS, ERROR, and SELECTION are stored in refs. When AUTO-LOAD is non-nil, the controller loads immediately and reloads after query or pagination refs change. NAME optionally labels the -controller for diagnostics. ITEM-KEY is a function used by -`etaf-data-selected-item' to match a selected identity to one loaded item. +controller for diagnostics. ITEM-KEY identifies selection and selected-item +state; it defaults to the source's `:item-key' capability when available. When OWNER-SCOPE is supplied, or when a current ETAF Scope exists, the controller's own child Scope is disposed with that owner; otherwise it keeps the detached Scope behavior. INITIAL-RESULT may be a normalized source result @@ -294,6 +334,7 @@ for QUERY/PAGE/PAGE-SIZE; it seeds a successful Controller without another load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." (unless (etaf-data-source-p source) (signal 'wrong-type-argument (list 'etaf-data-source-p source))) + (setq item-key (or item-key (plist-get source :item-key))) (unless (or (null item-key) (functionp item-key)) (signal 'wrong-type-argument (list 'functionp item-key))) (when (and initial-result auto-load) @@ -337,10 +378,11 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." :selection (etaf-ref (copy-sequence selection) :name 'etaf-data-selection) :selection-snapshot (copy-sequence selection) - :selected-refs (make-hash-table :test #'equal :weakness 'value) + :selected-refs (make-hash-table :test #'equal) :request-id 0 :auto-load-p auto-load :item-key item-key))) + (etaf-data--prepare-selected-refs controller initial-items) (etaf-scope-run scope (lambda () @@ -349,6 +391,8 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive." (lambda (new-selection old-selection) (setf (etaf-data--controller-selection-snapshot controller) new-selection) + (dolist (identity new-selection) + (etaf-data--ensure-selected-ref controller identity)) (let ((selected-refs (etaf-data--controller-selected-refs controller))) (unless (zerop (hash-table-count selected-refs)) @@ -490,6 +534,14 @@ The status value is one of `idle', `loading', `success', or `error'." (etaf-data--controller-selection (etaf-data--require-controller controller))) +;;;###autoload +(defun etaf-data-item-identity (controller item) + "Return ITEM's stable selection identity in CONTROLLER. + +The identity comes from the Controller's explicit `:item-key', then from its +source capability, and otherwise is ITEM itself." + (etaf-data--item-identity (etaf-data--require-controller controller) item)) + ;;;###autoload (defun etaf-data-selected-ref (controller identity) "Return CONTROLLER's stable boolean selection ref for IDENTITY. @@ -498,19 +550,8 @@ The returned ref changes only when IDENTITY enters or leaves the controller's selection. Repeated calls for the same identity return the same ref for the controller lifetime. Updates made through the selection APIs or by writing the public `etaf-data-selection' ref directly are both reflected." - (setq controller (etaf-data--require-controller controller)) - (let* ((refs (etaf-data--controller-selected-refs controller)) - (selected-ref (gethash identity refs))) - (or selected-ref - (let ((created - (etaf-ref - (not (null - (member identity - (etaf-data--controller-selection-snapshot - controller)))) - :name 'etaf-data-selected))) - (puthash identity created refs) - created)))) + (etaf-data--ensure-selected-ref + (etaf-data--require-controller controller) identity)) ;;;###autoload (defun etaf-data-selected-item (controller &optional item-key) diff --git a/etaf-renderer.el b/etaf-renderer.el index 24f1d4a..74e602e 100644 --- a/etaf-renderer.el +++ b/etaf-renderer.el @@ -526,12 +526,11 @@ multi-root forest; a single material root is returned unchanged." (let ((resolved (funcall (etaf--expr-thunk value)))) (cond ((null resolved) nil) ((stringp resolved) (list resolved)) - (t - (signal 'etaf-renderer-error - (list - (format - "Expr interpolation must return nil or string: %S" - resolved))))))) + ;; Text Hosts validate interpolation through + ;; `etaf--inline-text-content'. At a structural boundary the + ;; same evaluated value may be a dynamically produced View + ;; forest (notably a transparent Component's fragment). + (t (etaf--flatten-view-value resolved))))) ('branch (etaf--flatten-view-value (funcall (etaf--expr-thunk value)))) ('keyed-list @@ -752,8 +751,12 @@ multi-root forest; a single material root is returned unchanged." (or semantic-id etaf--current-semantic-parent-id))) (if (and semantic-id - (etaf--structural-program-p child) - (not etaf--rendering-range-p)) + ;; Code-mode may carry a retained + ;; structural Expr through `etaf-node'. + ;; Both compiler-owned programs and these + ;; validated Expr values use the same + ;; direct Range lowering boundary. + (etaf--expr-p child)) (let ((result (etaf--runtime-render-child-range etaf--render-runtime child @@ -763,8 +766,7 @@ multi-root forest; a single material root is returned unchanged." (cdr result)) (if (and semantic-id (etaf--view-node-p child) - (eq (etaf--view-node-name child) 'fragment) - (not etaf--rendering-range-p)) + (eq (etaf--view-node-name child) 'fragment)) (let ((result (etaf--runtime-render-fragment-range etaf--render-runtime child @@ -774,8 +776,7 @@ multi-root forest; a single material root is returned unchanged." (if (and semantic-id (etaf--slot-projection-p child) (etaf--slot-projection-range-compatible-p - child) - (not etaf--rendering-range-p)) + child)) (let ((result (etaf--runtime-render-slot-range etaf--render-runtime child diff --git a/etaf-runtime.el b/etaf-runtime.el index fc9ff0f..e615d6d 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -732,12 +732,24 @@ FULL-P means candidate tables describe the complete mounted tree." (etaf--semantic-range-range-ref semantic) (etaf--semantic-slot-range-range-ref semantic))) +(defun etaf--semantic-backend-range-semantic-id (semantic) + "Return retained semantic id for direct or slot Range SEMANTIC." + (if (etaf--semantic-range-p semantic) + (etaf--semantic-range-semantic-id semantic) + (etaf--semantic-slot-range-semantic-id semantic))) + (defun etaf--semantic-backend-range-container-component-id (semantic) "Return the Component containing backend Range SEMANTIC's artifact." (if (etaf--semantic-range-p semantic) (etaf--semantic-range-component-id semantic) (etaf--semantic-slot-range-consumer-component-id semantic))) +(defun etaf--semantic-backend-range-item-root-ids (semantic) + "Return direct material root ids owned by backend Range SEMANTIC." + (if (etaf--semantic-range-p semantic) + (etaf--semantic-range-item-root-ids semantic) + (etaf--semantic-slot-range-item-root-ids semantic))) + (defun etaf--generation-component-output-range (generation component) "Return COMPONENT's transparent output Range from GENERATION." (let* ((range-id (etaf--semantic-component-output-range-id component)) @@ -1495,6 +1507,19 @@ OLD-SEMANTIC supplies the already-read committed Host, when any." (puthash parent-id cell children)) (puthash parent-id cell tails))) +(defun etaf--runtime-range-must-refresh-for-component-input-p (expr) + "Return non-nil when EXPR's value is coupled to a Component rerender. +Compiler-owned branch/keyed programs and compiled direct Expr callsites may +read the current Component props while they materialize. Setup-retained +interpolation programs are opaque values and can safely reuse their Range +when only an unrelated parent structure changed." + (and etaf--rendering-component-effect-p + (or (memq (and (etaf--expr-p expr) (etaf--expr-kind expr)) + '(branch keyed-list)) + (and (etaf--expr-p expr) + (consp (etaf--expr-token expr)) + (eq (car (etaf--expr-token expr)) 'etaf-compiled-site))))) + (defun etaf--runtime-semantic-id-for-identity (runtime identity) "Return stable semantic id for IDENTITY in RUNTIME's current candidate." (or (gethash identity (etaf-runtime-candidate-identity-entries runtime)) @@ -1653,14 +1678,25 @@ receive an independent Host effect." (t (signal 'etaf-behavior-error (list (format "Invalid :use entry: %S" entry))))))) - (cond - ((null value) nil) - ((or (symbolp value) (etaf-behavior-spec-p value)) - (list (resolve value))) - ((proper-list-p value) (mapcar #'resolve value)) - (t - (signal 'etaf-behavior-error + (let ((specs + (cond + ((null value) nil) + ((or (symbolp value) (etaf-behavior-spec-p value)) + (list (resolve value))) + ((proper-list-p value) (mapcar #'resolve value)) + (t + (signal + 'etaf-behavior-error (list ":use must be a Behavior symbol, spec, or proper list")))))) + (let (names) + (dolist (spec specs) + (let ((name (etaf-behavior-spec-name spec))) + (when (memq name names) + (signal 'etaf-behavior-error + (list (format "Duplicate Behavior on one Host: %S" + name)))) + (push name names)))) + specs))) (defun etaf--runtime-target-value-equal-p (left right) "Compare LEFT and RIGHT with reactive/function identity rules." @@ -1860,9 +1896,25 @@ need to know how Behavior attributes are merged." "Attach current caller ownership to unowned normalized SLOTS." (mapcar (lambda (entry) - (let ((name (car entry)) (value (cdr entry))) + (let* ((name (car entry)) (value (cdr entry)) + ;; Code-mode forwarding uses `etaf-current-slot', which exposes + ;; the owned child list rather than the private SlotContent + ;; wrapper. Recover the wrapper by spine identity so the + ;; original author Component remains the lifecycle owner. + (forwarded-content + (cl-loop for forwarded in etaf--current-component-slots + for content = (cdr forwarded) + when (and (etaf--slot-content-p content) + value + (or (eq value + (etaf--slot-content-children content)) + (equal-including-properties + value + (etaf--slot-content-children content)))) + return content))) (cond ((etaf--slot-content-p value) entry) + (forwarded-content (cons name forwarded-content)) ((and (= (length value) 1) (etaf--slot-projection-p (car value))) (let* ((projection (car value)) @@ -2004,35 +2056,18 @@ need to know how Behavior attributes are merged." (let ((etaf--current-semantic-parent-id (or range-id etaf--current-semantic-parent-id)) (etaf--current-range-item-index - (and old-range - (etaf--semantic-range-item-identity-index old-range))) - ;; Material Components nested below an existing semantic - ;; Range flatten their child Range sites into that outer - ;; owner; Ebox must never receive nested descriptors. + (or (and old-range + (etaf--semantic-range-item-identity-index + old-range)) + etaf--current-range-item-index)) + ;; Rendering below a retained Range changes only how this + ;; Component publishes its own output. Descendant Range + ;; anchors remain semantic children and are never folded + ;; into their ancestor's identity. (etaf--rendering-range-p (or transparent-p etaf--rendering-range-p))) (etaf--render-value-list rendered (append path (list :view)))))) - (let ((child-ids - (copy-sequence - (gethash range-id - (etaf-runtime-candidate-graph-children runtime))))) - (when (= (length child-ids) (length nodes)) - (setq nodes - (cl-mapcan - (lambda (child-id node) - (let ((child - (gethash child-id - (etaf-runtime-candidate-graph-nodes runtime)))) - (cond - ((etaf--semantic-range-p child) - (copy-sequence - (etaf--runtime-range-nodes runtime child))) - ((etaf--semantic-slot-range-p child) - (copy-sequence - (etaf--runtime-range-nodes runtime child))) - (t (list node))))) - child-ids nodes)))) (when (cl-some (lambda (node) (memq node etaf--rendered-range-container-nodes)) nodes) @@ -2480,19 +2515,6 @@ need to know how Behavior attributes are merged." (let* ((name (etaf--semantic-host-name semantic)) (props (copy-tree (etaf--semantic-host-props-signature semantic))) (child-ids (etaf--semantic-host-child-ids semantic)) - (parent-semantic - (and (etaf--semantic-host-parent-id semantic) - (etaf--pvec-get - (etaf-generation-semantic-nodes generation) - (etaf--semantic-host-parent-id semantic)))) - ;; A semantic Range may contain one material Host anchor whose - ;; descendants include another Range. Flatten that nested - ;; semantic Range at the Renderer boundary so Ebox receives only - ;; declarative children; the outer Range remains the publication - ;; identity and ancestor invalidation still follows the graph. - (flatten-range-children-p - (or (etaf--semantic-range-p parent-semantic) - (etaf--semantic-slot-range-p parent-semantic))) (content (if (eq name 'text) (if (etaf--semantic-host-content-parts semantic) @@ -2510,30 +2532,20 @@ need to know how Behavior attributes are merged." (etaf--semantic-host-content semantic))) (children (unless (eq name 'text) - (cl-mapcan + (mapcar (lambda (child-id) - (let ((child (etaf--pvec-get - (etaf-generation-semantic-nodes generation) - child-id))) - (if (and flatten-range-children-p - (or (etaf--semantic-range-p child) - (etaf--semantic-slot-range-p child))) - (copy-sequence - (etaf--runtime-range-nodes runtime child)) - (list - (etaf--runtime-lower-semantic-artifact - runtime generation child-id))))) + (etaf--runtime-lower-semantic-artifact + runtime generation child-id)) child-ids))) (range-child-p - (and (not flatten-range-children-p) - (cl-some - (lambda (child-id) - (let ((child (etaf--pvec-get - (etaf-generation-semantic-nodes generation) - child-id))) - (or (etaf--semantic-range-p child) - (etaf--semantic-slot-range-p child)))) - child-ids)))) + (cl-some + (lambda (child-id) + (let ((child (etaf--pvec-get + (etaf-generation-semantic-nodes generation) + child-id))) + (or (etaf--semantic-range-p child) + (etaf--semantic-slot-range-p child)))) + child-ids))) (etaf--lower-resolved-semantic-host name props content children range-child-p))) @@ -2743,7 +2755,13 @@ need to know how Behavior attributes are merged." (copy-sequence (etaf--runtime-range-nodes runtime candidate)))))) (if (and old - (not etaf--rendering-component-effect-p) + ;; A parent Component may rerender because a preceding static + ;; sibling changed while this direct Range did not. Its stable + ;; site token and retained artifact are sufficient to reuse the + ;; Range; a genuinely dirty Range effect still takes the render + ;; branch below. + (not (etaf--runtime-range-must-refresh-for-component-input-p + expr)) (not (gethash effect-id (etaf-runtime-dirty-effect-ids runtime)))) (progn (puthash identity semantic-id @@ -2771,9 +2789,13 @@ need to know how Behavior attributes are merged." (etaf--runtime-keyed-range-snapshot expr)) (setq value (etaf--runtime-normalize-range-value + ;; Keyed item renderers may intentionally return a + ;; transparent Component span; ordinary direct Expr + ;; ranges still fail closed on Component output. (if keyed-snapshot (etaf--keyed-program-outputs expr keyed-snapshot) - (funcall (etaf--expr-thunk expr)))))) + (funcall (etaf--expr-thunk expr))) + (not (null keyed-snapshot))))) (puthash identity semantic-id (etaf-runtime-candidate-identity-entries runtime)) (etaf--runtime-candidate-add-child @@ -2805,6 +2827,7 @@ need to know how Behavior attributes are merged." expr keyed-snapshot (plist-get range-render :item-root-groups) (plist-get range-render :item-node-counts))) + (input (etaf--ebox-input-for-nodes nodes)) (record (etaf--semantic-range-create :semantic-id semantic-id :identity identity :effect-id effect-id @@ -2845,8 +2868,18 @@ need to know how Behavior attributes are merged." :semantic-id semantic-id :deps (etaf--semantic-range-deps record) :target expr) (etaf-runtime-candidate-effects runtime)) - (puthash effect-id (etaf--ebox-input-for-nodes nodes) + (puthash effect-id input (etaf-runtime-candidate-range-artifacts runtime)) + (when (and old + (not (ebox-canonical-input-equal-p + (etaf--runtime-committed-range-input runtime old) + input))) + (push (list old record + (etaf--runtime-committed-range-input runtime old) + input nil) + (etaf-runtime-candidate-eager-range-changes runtime)) + (etaf--runtime-invalidate-range-ancestors runtime old) + (etaf--runtime-record-range-owner-update runtime old)) (cons 'range (list (apply #'ebox-child-range range-ref nodes))))))))) @@ -3050,27 +3083,38 @@ The candidate uses resolved VALUE, DEPS, and NODES." styled) item))) -(defun etaf--runtime-normalize-range-value (value) - "Return Host/string RANGE VALUE with nested expr sites eagerly resolved." + (defun etaf--runtime-normalize-range-value (value &optional allow-components-p) + "Return normalized RANGE VALUE with nested Expr sites eagerly resolved. +When ALLOW-COMPONENTS-P is non-nil, keyed item boundaries may contain +Component calls whose retained output is owned by the keyed Range." (cond ((null value) nil) ((stringp value) (list value)) - ((or (etaf--component-call-p value) - (etaf--slot-projection-p value)) + ((and allow-components-p + (or (etaf--component-call-p value) + (etaf--slot-projection-p value))) (list value)) ((etaf--expr-p value) - (etaf--runtime-normalize-range-value (funcall (etaf--expr-thunk value)))) + (etaf--runtime-normalize-range-value + (funcall (etaf--expr-thunk value)) allow-components-p)) ((etaf--view-node-p value) (if (eq (etaf--view-node-name value) 'fragment) - (cl-mapcan #'etaf--runtime-normalize-range-value + (cl-mapcan (lambda (child) + (etaf--runtime-normalize-range-value + child allow-components-p)) (etaf--view-node-children value)) (let ((copy (copy-sequence value))) (setf (etaf--view-node-children copy) - (cl-mapcan #'etaf--runtime-normalize-range-value - (etaf--view-node-children value))) + (cl-loop for child in (etaf--view-node-children value) + append + (etaf--runtime-normalize-range-value + child allow-components-p))) (list copy)))) ((proper-list-p value) - (cl-mapcan #'etaf--runtime-normalize-range-value value)) + (cl-mapcan (lambda (child) + (etaf--runtime-normalize-range-value + child allow-components-p)) + value)) (t (signal 'etaf-runtime-error (list "Direct material expr requires Step4b output"))))) @@ -3095,7 +3139,8 @@ The candidate uses resolved VALUE, DEPS, and NODES." (defun etaf--runtime-keyed-range-keys (expr snapshot) "Return validated keys for EXPR aligned with keyed SNAPSHOT items." - (or (plist-get snapshot :keys) + (if (plist-member snapshot :keys) + (plist-get snapshot :keys) (let ((key-function (etaf--expr-range-key expr))) (unless (functionp key-function) (signal 'etaf-runtime-error @@ -3619,17 +3664,41 @@ Generation, including its effects and Host contributions." (make-hash-table :test #'equal))) (identity-copy nil) (affected-sources (make-hash-table :test #'eq)) + (effect-map-shadow (make-hash-table :test #'eql)) + (effect-sources-shadow (make-hash-table :test #'eql)) + (source-effects-shadow (make-hash-table :test #'eql)) + (missing-index-value (make-symbol "etaf-missing-index-value")) deltas - node-updates resource-updates) + node-updates resource-updates + effect-map-update-ids effect-sources-update-ids + source-effects-update-ids) (cl-labels - ((install-effect + ((index-value + (shadow root id kind) + (let ((value (gethash id shadow missing-index-value))) + (if (eq value missing-index-value) + (etaf--pvec-get root id metrics kind) + value))) + (stage-index-value + (shadow ids id value) + (let ((new-p (eq (gethash id shadow missing-index-value) + missing-index-value))) + (puthash id value shadow) + (if new-p (cons id ids) ids))) + (staged-index-entries + (shadow ids) + (mapcar (lambda (id) (cons id (gethash id shadow))) + (nreverse ids))) + (install-effect (effect old-deps new-deps) (let ((effect-id (etaf--generation-effect-effect-id effect))) - (setq effect-map - (etaf--pvec-put effect-map effect-id effect metrics) - effect-sources - (etaf--pvec-put effect-sources effect-id - (copy-sequence new-deps) metrics)) + (setq effect-map-update-ids + (stage-index-value effect-map-shadow effect-map-update-ids + effect-id effect) + effect-sources-update-ids + (stage-index-value effect-sources-shadow + effect-sources-update-ids effect-id + (copy-sequence new-deps))) (dolist (source (cl-delete-duplicates (append (copy-sequence old-deps) (copy-sequence new-deps)) @@ -3638,39 +3707,42 @@ Generation, including its effects and Host contributions." (let* ((source-id (etaf-reactive-source-id source)) (current-effects (copy-sequence - (etaf--pvec-get source-effects source-id - metrics 'source))) + (index-value source-effects-shadow source-effects + source-id 'source))) (new-effects (delq effect-id current-effects))) (when (memq source new-deps) (setq new-effects (sort (cons effect-id new-effects) #'<))) (unless (equal current-effects new-effects) - (setq source-effects - (etaf--pvec-put source-effects source-id - new-effects metrics))))))) + (setq source-effects-update-ids + (stage-index-value source-effects-shadow + source-effects-update-ids + source-id new-effects))))))) (remove-effect (effect-id) (when-let* ((old-effect - (and effect-map - (etaf--pvec-get effect-map effect-id metrics - 'effect)))) + (index-value effect-map-shadow effect-map effect-id + 'effect))) (let ((deps (etaf--generation-effect-deps old-effect))) - (setq effect-map - (etaf--pvec-put effect-map effect-id nil metrics) - effect-sources - (etaf--pvec-put effect-sources effect-id nil metrics)) + (setq effect-map-update-ids + (stage-index-value effect-map-shadow effect-map-update-ids + effect-id nil) + effect-sources-update-ids + (stage-index-value effect-sources-shadow + effect-sources-update-ids effect-id nil)) (dolist (source deps) (puthash source t affected-sources) (let* ((source-id (etaf-reactive-source-id source)) (current-effects (copy-sequence - (etaf--pvec-get source-effects source-id metrics - 'source))) + (index-value source-effects-shadow source-effects + source-id 'source))) (new-effects (delq effect-id current-effects))) (unless (equal current-effects new-effects) - (setq source-effects - (etaf--pvec-put source-effects source-id - new-effects metrics)))))))) + (setq source-effects-update-ids + (stage-index-value source-effects-shadow + source-effects-update-ids + source-id new-effects)))))))) (semantic-effect-ids (semantic) (cond @@ -3732,31 +3804,32 @@ Generation, including its effects and Host contributions." (dolist (effect-id (etaf-runtime-candidate-removed-effect-ids runtime)) (remove-effect effect-id)) (dolist (semantic-id (etaf-runtime-candidate-removed-semantic-ids runtime)) - (when-let* ((old-node (and base - (etaf--pvec-get - (etaf-generation-semantic-nodes base) - semantic-id)))) - ;; A stable identity may be reintroduced in this candidate. In that - ;; case its new effect is installed below; only remove effects for a - ;; semantic node that is absent from the candidate graph. - (unless (gethash semantic-id - (etaf-runtime-candidate-graph-nodes runtime)) - (dolist (effect-id (semantic-effect-ids old-node)) - (remove-effect effect-id))) - (when (and (etaf--semantic-host-p old-node) - (etaf--semantic-host-host-ref old-node)) - (let ((host-ref (etaf--semantic-host-host-ref old-node))) - ;; A dirty Component may remove and recreate the same stable - ;; Host address in one candidate. The new contribution wins; - ;; do not leave a removal tombstone that shadows it. - (unless (or (gethash host-ref - (etaf-runtime-candidate-host-props runtime)) - (gethash host-ref - (etaf-runtime-candidate-handlers runtime))) - (cl-pushnew host-ref - (etaf-runtime-candidate-removed-host-refs runtime) - :test #'equal))))) - (push (cons semantic-id nil) node-updates)) + (let ((live-p + (gethash semantic-id + (etaf-runtime-candidate-graph-nodes runtime)))) + ;; Replacement may reintroduce a stable descendant below a new + ;; ancestor. Candidate liveness wins over the old subtree's removal + ;; journal for both the node and its effects. + (unless live-p + (when-let* ((old-node (and base + (etaf--pvec-get + (etaf-generation-semantic-nodes base) + semantic-id)))) + (dolist (effect-id (semantic-effect-ids old-node)) + (remove-effect effect-id)) + (when (and (etaf--semantic-host-p old-node) + (etaf--semantic-host-host-ref old-node)) + (let ((host-ref (etaf--semantic-host-host-ref old-node))) + (unless (or + (gethash host-ref + (etaf-runtime-candidate-host-props runtime)) + (gethash host-ref + (etaf-runtime-candidate-handlers runtime))) + (cl-pushnew + host-ref + (etaf-runtime-candidate-removed-host-refs runtime) + :test #'equal))))) + (push (cons semantic-id nil) node-updates)))) (maphash (lambda (identity semantic-id) (unless (gethash identity identity-index) @@ -3800,7 +3873,24 @@ Generation, including its effects and Host contributions." ;; Apply all semantic/index membership edits in one trie batch. The ;; candidate remains immutable; only the number of copied persistent ;; vector spines changes. - (setq nodes + (setq effect-map + (etaf--pvec-put-many effect-map + (staged-index-entries + effect-map-shadow effect-map-update-ids) + metrics) + effect-sources + (etaf--pvec-put-many effect-sources + (staged-index-entries + effect-sources-shadow + effect-sources-update-ids) + metrics) + source-effects + (etaf--pvec-put-many source-effects + (staged-index-entries + source-effects-shadow + source-effects-update-ids) + metrics) + nodes (etaf--pvec-put-many nodes node-updates metrics) resources (etaf--pvec-put-many resources resource-updates metrics)) @@ -4107,64 +4197,46 @@ removed inside the same rollback journal." (defun etaf--runtime-evaluate-component-input (runtime semantic) "Recompute RUNTIME SEMANTIC input and enqueue render only when it differs." - (let* ((generation (etaf-runtime-current-generation runtime)) - (caller-id (etaf--semantic-component-caller-component-id semantic)) - (base-caller - (and caller-id - (etaf--pvec-get (etaf-generation-semantic-nodes generation) - caller-id))) - (caller - (and base-caller - (or (gethash (etaf--semantic-component-identity base-caller) - (etaf-runtime-candidate-semantic-nodes runtime)) - base-caller))) - (instance - (and caller - (gethash (etaf--semantic-component-resource-key caller) - (etaf-runtime-resource-registry runtime)))) + (let* ((caller-id (etaf--semantic-component-caller-component-id semantic)) deps) - (let ((etaf--runtime-dependency-collector - (lambda (source) (cl-pushnew source deps :test #'eq))) - (etaf--current-runtime runtime) - (etaf--current-component-instance instance) - (etaf--current-component-identity - (and caller (etaf--semantic-component-identity caller))) - (etaf--current-component-semantic-id caller-id) - (etaf--current-component-props - (and caller (etaf--semantic-component-props caller))) - (etaf--current-component-slots - (and caller (etaf--semantic-component-slots caller))) - (etaf--current-context - (and caller (etaf--semantic-component-context-frame caller))) - (etaf--active-effect nil) - (etaf--render-phase-p t)) - (let* ((props (etaf--resolve-property-plist - (etaf--semantic-component-input-props semantic))) - (attrs (etaf--resolve-property-plist - (etaf--semantic-component-input-attrs semantic))) - (slots (etaf--semantic-component-input-slots semantic)) - (candidate (copy-sequence semantic)) - (effect-id (etaf--semantic-component-input-effect-id semantic))) - (setf (etaf--semantic-component-props candidate) (copy-tree props) - (etaf--semantic-component-attrs candidate) (copy-tree attrs) - (etaf--semantic-component-slots candidate) (copy-tree slots) - (etaf--semantic-component-input-deps candidate) (nreverse deps)) - (puthash (etaf--semantic-component-identity semantic) candidate - (etaf-runtime-candidate-semantic-nodes runtime)) - (puthash effect-id - (etaf--generation-effect-create - :effect-id effect-id :kind 'component-input - :semantic-id (etaf--semantic-component-semantic-id semantic) - :deps (etaf--semantic-component-input-deps candidate)) - (etaf-runtime-candidate-effects runtime)) - (unless (and (etaf--runtime-target-value-equal-p - props (etaf--semantic-component-props semantic)) - (etaf--runtime-target-value-equal-p - attrs (etaf--semantic-component-attrs semantic)) - (etaf--runtime-target-value-equal-p - slots (etaf--semantic-component-slots semantic))) - (etaf--runtime-enqueue-effect - runtime (etaf--semantic-component-effect-id semantic))))))) + (etaf--runtime-call-with-component-env + runtime caller-id + (lambda () + (let ((etaf--runtime-dependency-collector + (lambda (source) (cl-pushnew source deps :test #'eq))) + (etaf--active-effect nil) + (etaf--render-phase-p t)) + (let* ((props (etaf--resolve-property-plist + (etaf--semantic-component-input-props semantic))) + (attrs (etaf--resolve-property-plist + (etaf--semantic-component-input-attrs semantic))) + (slots (etaf--semantic-component-input-slots semantic)) + (candidate (copy-sequence semantic)) + (effect-id + (etaf--semantic-component-input-effect-id semantic))) + (setf (etaf--semantic-component-props candidate) (copy-tree props) + (etaf--semantic-component-attrs candidate) (copy-tree attrs) + (etaf--semantic-component-slots candidate) (copy-tree slots) + (etaf--semantic-component-input-deps candidate) + (nreverse deps)) + (puthash (etaf--semantic-component-identity semantic) candidate + (etaf-runtime-candidate-semantic-nodes runtime)) + (puthash effect-id + (etaf--generation-effect-create + :effect-id effect-id :kind 'component-input + :semantic-id + (etaf--semantic-component-semantic-id semantic) + :deps (etaf--semantic-component-input-deps candidate)) + (etaf-runtime-candidate-effects runtime)) + (unless + (and (etaf--runtime-target-value-equal-p + props (etaf--semantic-component-props semantic)) + (etaf--runtime-target-value-equal-p + attrs (etaf--semantic-component-attrs semantic)) + (etaf--runtime-target-value-equal-p + slots (etaf--semantic-component-slots semantic))) + (etaf--runtime-enqueue-effect + runtime (etaf--semantic-component-effect-id semantic))))))))) (defun etaf--runtime-retarget-component-slot-ranges (runtime semantic slots) "Retarget SEMANTIC projection slot effects to candidate SLOTS in RUNTIME." @@ -4579,6 +4651,22 @@ the range is not eligible for keyed incremental rendering." (cl-pushnew (cons (etaf-context-owner-id frame) key) context-deps :test #'equal))) (etaf--render-runtime runtime) + (etaf--current-runtime runtime) + (etaf--current-component-instance instance) + (etaf--current-component-state + (etaf--component-instance-state instance)) + (etaf--current-component-setup-defined-p + (not (null (etaf--component-spec-setup + (etaf--component-instance-spec instance))))) + (etaf--current-component-setup-complete-p + (etaf--component-instance-setup-complete-p instance)) + (etaf--component-phase 'render) + (etaf--current-component-identity + (etaf--semantic-component-identity component)) + (etaf--current-component-props + (etaf--semantic-component-props component)) + (etaf--current-component-slots + (etaf--semantic-component-slots component)) (etaf--current-context (etaf--semantic-component-context-frame component)) (etaf--current-component-semantic-id @@ -4658,7 +4746,8 @@ the range is not eligible for keyed incremental rendering." (etaf-runtime-candidate-graph-children runtime)))) (value (etaf--runtime-normalize-range-value - (funcall item-function item context))) + (funcall item-function item context) + t)) (rendered (etaf--render-value-list value @@ -4687,7 +4776,11 @@ the range is not eligible for keyed incremental rendering." :item-node-counts (nreverse item-node-counts) :deps (nreverse deps) :context-deps (nreverse context-deps) - :reuse-map (nreverse reuse-map))))))))) + :reuse-map (nreverse reuse-map) + ;; Ebox validates every non-reused slot against this input's + ;; source generation; reused slots are replaced by their + ;; exact published objects from the explicit reuse map. + :retain-item-identities-p t)))))))) (defun etaf--runtime-render-dirty-range (runtime effect range) "Evaluate RUNTIME dirty RANGE EFFECT without running its Component owner." @@ -4748,32 +4841,32 @@ the range is not eligible for keyed incremental rendering." (etaf--runtime-normalize-range-value (funcall (etaf--expr-thunk (etaf--generation-effect-target effect)))))) - (let ((etaf--runtime-dependency-collector collector) - (etaf--context-inject-recorder - (lambda (frame key) - (cl-pushnew (cons (etaf-context-owner-id frame) key) - context-deps :test #'equal))) - (etaf--render-runtime runtime) - ;; Static style tokens are lowered in this second pass. Preserve - ;; only the owning Context frame needed by Theme resolution; the - ;; range semantic ids below already provide the runtime lowering - ;; identity, and the other Component bindings belong to the value - ;; normalization pass above. - (etaf--current-context - (etaf--semantic-component-context-frame component)) - (etaf--current-component-semantic-id - (etaf--semantic-range-component-id range)) - (etaf--current-semantic-parent-id - (etaf--semantic-range-semantic-id range)) - (etaf--current-range-item-index - (etaf--semantic-range-item-identity-index range)) - (etaf--rendering-range-p t) - (etaf--active-effect nil) - (etaf--render-phase-p t) - (etaf--render-style-stack - (copy-tree (etaf--semantic-range-caller-style-stack range)))) - (setq nodes (etaf--render-value-list - value (etaf--semantic-range-path range)))))) + ;; Lowering may resolve property expressions on Component calls + ;; produced by the Range. Keep the lexical Component environment for + ;; both normalization and lowering; otherwise prop symbol macros read + ;; an empty dynamic environment during an independent Range update. + (etaf--runtime-call-with-component-env + runtime (etaf--semantic-range-component-id range) + (lambda () + (let ((etaf--runtime-dependency-collector collector) + (etaf--context-inject-recorder + (lambda (frame key) + (cl-pushnew (cons (etaf-context-owner-id frame) key) + context-deps :test #'equal))) + (etaf--render-runtime runtime) + (etaf--current-component-semantic-id + (etaf--semantic-range-component-id range)) + (etaf--current-semantic-parent-id + (etaf--semantic-range-semantic-id range)) + (etaf--current-range-item-index + (etaf--semantic-range-item-identity-index range)) + (etaf--rendering-range-p t) + (etaf--active-effect nil) + (etaf--render-phase-p t) + (etaf--render-style-stack + (copy-tree (etaf--semantic-range-caller-style-stack range)))) + (setq nodes (etaf--render-value-list + value (etaf--semantic-range-path range)))))))) (let* ((item-root-ids (copy-sequence (gethash (etaf--semantic-range-semantic-id range) @@ -4838,7 +4931,12 @@ the range is not eligible for keyed incremental rendering." (list range candidate (etaf--runtime-committed-range-input runtime range) (etaf--runtime-range-input runtime candidate) - (plist-get keyed :reuse-map))))))) + (plist-get keyed :reuse-map) + ;; A keyed render with no reused item owns every payload node in + ;; this candidate source generation. Ebox rechecks that proof + ;; before retaining identity; other Range paths keep copy-based + ;; fallback semantics. + (plist-get keyed :retain-item-identities-p))))))) (defun etaf--runtime-record-range-owner-update (runtime range) "Record RANGE's lexical Component lifecycle participation in RUNTIME." @@ -4969,6 +5067,110 @@ the range is not eligible for keyed incremental rendering." (and ref (ebox-range-ref-present-p (etaf-runtime-buffer runtime) ref)))) +(defun etaf--runtime-range-direct-node-signature + (runtime generation semantic-id candidate-p) + "Return SEMANTIC-ID's direct material signature. +When CANDIDATE-P is non-nil, read the candidate overlay before GENERATION. +Nested Range identity is retained, but its internal artifact is deliberately +excluded so descendant-only work cannot masquerade as an ancestor change." + (let ((semantic + (or (and candidate-p + (gethash semantic-id + (etaf-runtime-candidate-graph-nodes runtime))) + (etaf--pvec-get + (etaf-generation-semantic-nodes generation) semantic-id)))) + (cond + ((etaf--semantic-host-p semantic) + (list 'host + (etaf--semantic-host-identity semantic) + (etaf--semantic-host-name semantic) + (etaf--semantic-host-props-signature semantic) + (etaf--semantic-host-content semantic) + (mapcar + (lambda (part) + (if (integerp part) + (etaf--runtime-range-direct-node-signature + runtime generation part candidate-p) + part)) + (etaf--semantic-host-content-parts semantic)) + (mapcar + (lambda (child-id) + (etaf--runtime-range-direct-node-signature + runtime generation child-id candidate-p)) + (etaf--semantic-host-child-ids semantic)))) + ((etaf--semantic-component-p semantic) + (list 'component + (etaf--semantic-component-identity semantic) + (etaf--semantic-component-publication-kind semantic) + (mapcar + (lambda (child-id) + (etaf--runtime-range-direct-node-signature + runtime generation child-id candidate-p)) + (etaf--semantic-component-child-ids semantic)))) + ((or (etaf--semantic-range-p semantic) + (etaf--semantic-slot-range-p semantic)) + (list 'range-anchor + (etaf--semantic-backend-range-semantic-id semantic) + (etaf--semantic-backend-range-ref semantic))) + ((etaf--semantic-inline-range-p semantic) + (list 'inline (etaf--semantic-inline-range-output semantic))) + (t (list 'missing semantic-id))))) + +(defun etaf--runtime-range-direct-payload-equal-p + (runtime generation old candidate) + "Return whether OLD and CANDIDATE own the same direct Range payload." + (and (equal + (etaf--semantic-backend-range-item-root-ids old) + (etaf--semantic-backend-range-item-root-ids candidate)) + (equal-including-properties + (mapcar + (lambda (semantic-id) + (etaf--runtime-range-direct-node-signature + runtime generation semantic-id nil)) + (etaf--semantic-backend-range-item-root-ids old)) + (mapcar + (lambda (semantic-id) + (etaf--runtime-range-direct-node-signature + runtime generation semantic-id t)) + (etaf--semantic-backend-range-item-root-ids candidate))))) + +(defun etaf--runtime-normalize-range-changes (runtime generation changes) + "Return non-overlapping CHANGES ordered as originally staged. +An ancestor absorbs descendants only when its own direct material payload +changed. If its root identity/cardinality and direct payload are stable, its +staged artifact differs solely because it contains a descendant candidate; +drop that ancestor and publish the deepest direct change instead." + (let ((changed (make-hash-table :test #'eql)) + (direct-changed (make-hash-table :test #'eql)) + normalized) + (dolist (change changes) + (when-let* ((range (car change))) + (puthash (etaf--semantic-backend-range-semantic-id range) + change changed))) + (maphash + (lambda (semantic-id change) + (unless (etaf--runtime-range-direct-payload-equal-p + runtime generation (car change) (cadr change)) + (puthash semantic-id t direct-changed))) + changed) + (dolist (change changes) + (let* ((range (car change)) + (semantic-id + (etaf--semantic-backend-range-semantic-id range)) + (parent-id (etaf--generation-parent-id generation semantic-id)) + absorbed-p) + (while (and parent-id (not absorbed-p)) + (when (gethash parent-id direct-changed) + (setq absorbed-p t)) + (unless absorbed-p + (setq parent-id + (etaf--generation-parent-id generation parent-id)))) + (unless (or absorbed-p + (not (gethash semantic-id direct-changed)) + (not (eq change (gethash semantic-id changed)))) + (push change normalized)))) + (nreverse normalized))) + (defun etaf--runtime-invalidate-semantic-ancestors (runtime parent-id) "Invalidate RUNTIME artifacts from PARENT-ID through semantic ancestors." (let* ((generation (etaf-runtime-current-generation runtime)) @@ -5132,7 +5334,35 @@ RENDERED-IDENTITIES names the Component render participants." runtime old base-semantic)) (pcase (etaf--generation-effect-kind effect) ('component-input - (etaf--runtime-evaluate-component-input runtime semantic)) + (etaf--runtime-evaluate-component-input runtime semantic) + ;; Input evaluation may enqueue the Component render while + ;; lower-priority inline/Range effects are already waiting + ;; in this turn. Restore the priority order immediately + ;; so the render observes the final input before those + ;; effects can seed a stale candidate. + (setf (etaf-runtime-dirty-effect-queue runtime) + (etaf--runtime-sort-dirty-effects + old + (etaf-runtime-dirty-effect-queue runtime)) + (etaf-runtime-dirty-effect-queue-tail runtime) + (last (etaf-runtime-dirty-effect-queue runtime))) + ;; `component-render' deliberately keeps its historical + ;; sort class for the public priority contract, but a + ;; render created by this input update must run before an + ;; already queued child Range/inline effect. Move only + ;; this known dependent to the front of the remaining + ;; turn; the ordinary FIFO remains unchanged otherwise. + (let ((render-id + (etaf--semantic-component-effect-id semantic))) + (when (gethash render-id + (etaf-runtime-dirty-effect-ids runtime)) + (setf (etaf-runtime-dirty-effect-queue runtime) + (cons + render-id + (delq render-id + (etaf-runtime-dirty-effect-queue runtime))) + (etaf-runtime-dirty-effect-queue-tail runtime) + (last (etaf-runtime-dirty-effect-queue runtime)))))) ('component-render (unless (member (etaf--semantic-component-identity semantic) (etaf-runtime-candidate-rendered-identities @@ -5170,37 +5400,6 @@ RENDERED-IDENTITIES names the Component render participants." (ebox-canonical-input-equal-p (nth 2 change) (nth 3 change))) range-changes)) - ;; A semantic Range may be nested below a material Component whose - ;; backend publication exposes only the ancestor component-output anchor. - ;; Never submit an address that Ebox cannot resolve against this base; - ;; discard the local candidate and let the next branch publish one exact - ;; root candidate. This is a proof miss, not an exception path. - (let (fallback-component-effect-ids fallback-p) - (dolist (change range-changes) - (unless (etaf--runtime-range-change-has-backend-anchor-p - runtime change) - (setq fallback-p t) - (when-let* ((range (car change)) - (component-id - (etaf--semantic-backend-range-container-component-id - range)) - (component - (etaf--pvec-get - (etaf-generation-semantic-nodes old) component-id))) - (cl-pushnew - (etaf--semantic-component-effect-id component) - fallback-component-effect-ids :test #'eql)))) - (when fallback-p - ;; Re-render the material owner during the root fallback. A root - ;; rebuild may otherwise carry its old artifact and leave the source - ;; value visually stale even though the invalid Range was discarded. - (etaf--runtime-mark-root-dirty runtime) - (etaf--runtime-clear-dirty-effects runtime) - (dolist (effect-id fallback-component-effect-ids) - (puthash effect-id t (etaf-runtime-dirty-effect-ids runtime))) - (etaf--runtime-dispose-created-candidate runtime) - (etaf--runtime-clear-candidate runtime) - (cl-return-from etaf--runtime-component-overlay :root-fallback))) (let (material-changes) (dolist (change changes) (let ((candidate (car change))) @@ -5250,6 +5449,39 @@ RENDERED-IDENTITIES names the Component render participants." (member (etaf--semantic-component-identity component) backend-component-identities))) range-changes)) + (setq range-changes + (etaf--runtime-normalize-range-changes runtime old range-changes)) + ;; A semantic Range may be nested below a material Component whose + ;; backend publication exposes only the ancestor component-output anchor. + ;; Never submit an address that Ebox cannot resolve against this base; + ;; discard the local candidate and let the next branch publish one exact + ;; root candidate. This is a proof miss, not an exception path. + (let (fallback-component-effect-ids fallback-p) + (dolist (change range-changes) + (unless (etaf--runtime-range-change-has-backend-anchor-p + runtime change) + (setq fallback-p t) + (when-let* ((range (car change)) + (component-id + (etaf--semantic-backend-range-container-component-id + range)) + (component + (etaf--pvec-get + (etaf-generation-semantic-nodes old) component-id))) + (cl-pushnew + (etaf--semantic-component-effect-id component) + fallback-component-effect-ids :test #'eql)))) + (when fallback-p + ;; Re-render the material owner during the root fallback. A root + ;; rebuild may otherwise carry its old artifact and leave the source + ;; value visually stale even though the invalid Range was discarded. + (etaf--runtime-mark-root-dirty runtime) + (etaf--runtime-clear-dirty-effects runtime) + (dolist (effect-id fallback-component-effect-ids) + (puthash effect-id t (etaf-runtime-dirty-effect-ids runtime))) + (etaf--runtime-dispose-created-candidate runtime) + (etaf--runtime-clear-candidate runtime) + (cl-return-from etaf--runtime-component-overlay :root-fallback))) (setq candidate-generation (etaf--runtime-build-generation runtime old) ;; Component artifacts are first produced while dirty effects are ;; still being evaluated. Rebuild material publication roots from @@ -5313,9 +5545,20 @@ RENDERED-IDENTITIES names the Component render participants." (ebox-canonical-input-root-host-ref (nth 1 change)) (nth 2 change))) (dolist (change range-changes) - (ebox-candidate-replace-range-ref - candidate (etaf--semantic-backend-range-ref (car change)) - (nth 3 change) (nth 4 change))) + (let ((reuse-map (nth 4 change)) + (retain-item-identities-p (nth 5 change))) + ;; Keep the optional identity-retention flag off the call + ;; when it is not needed. Besides avoiding an unnecessary + ;; argument on the common path, this preserves the stable + ;; three/four-argument integration boundary for callers + ;; which only observe ordinary Range replacement. + (if retain-item-identities-p + (ebox-candidate-replace-range-ref + candidate (etaf--semantic-backend-range-ref (car change)) + (nth 3 change) reuse-map retain-item-identities-p) + (ebox-candidate-replace-range-ref + candidate (etaf--semantic-backend-range-ref (car change)) + (nth 3 change) reuse-map)))) (dolist (change inline-changes) (ebox-candidate-replace-host-ref candidate (etaf--semantic-host-host-ref (car change)) diff --git a/etaf-view.el b/etaf-view.el index b2437b7..42a12c4 100644 --- a/etaf-view.el +++ b/etaf-view.el @@ -776,8 +776,8 @@ Return `(BUSINESS ATTRS)'. `:key' remains framework-owned input metadata." (when (gethash domain attr-domains) (etaf--component-error "Duplicate Component Host attribute domain: %S" key)) - (puthash domain t attr-domains)) - (setq attrs (append attrs (list key value)))) + (puthash domain t attr-domains) + (setq attrs (append attrs (list domain value))))) (t (etaf--component-error "Unknown prop or Host attribute %S for Component %S" @@ -794,6 +794,11 @@ Return `(BUSINESS ATTRS)'. `:key' remains framework-owned input metadata." "Return non-nil when VALUE is one already validated View child." (or (null value) (stringp value) + ;; Code-mode setup may retain a structural program (for example, a + ;; direct Range expression) and pass that opaque value to `etaf-node'. + ;; It is still validated and interpreted only at the renderer boundary; + ;; arbitrary lists remain rejected here. + (etaf--expr-p value) (etaf--view-node-p value) (etaf--component-call-p value) (etaf--slot-projection-p value))) diff --git a/examples/etaf-counter-example.el b/examples/etaf-counter-example.el index b70811d..6a14be8 100644 --- a/examples/etaf-counter-example.el +++ b/examples/etaf-counter-example.el @@ -25,67 +25,25 @@ ('reset 0) (_ (user-error "Unknown counter operation: %S" operation))))) -(defun etaf-counter-example--header (title) - "Return the counter header for TITLE." - (etaf-view - (box :class "hero" - (column - (text :class "eyebrow" "BEST PRACTICE / RETAINED STATE") - (text :font-weight 'bold (expr :value title)) - (text :color "#66706A" - "State belongs to setup; rendering only reads it."))))) - -(defun etaf-counter-example--metrics (count double status) - "Return metric cards for COUNT, DOUBLE, and STATUS." - (etaf-view - (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) - (box :class "metric" - (text (expr :value (format "COUNT %d" (etaf-value count))))) - (box :class "metric" - (text (expr :value (format "DOUBLE %d" (etaf-value double))))) - (box :class "metric" - (text (expr :value (format "STATE %s" (etaf-value status)))))))) - -(defun etaf-counter-example--action (count label host-ref operation) - "Return one COUNT action named LABEL using HOST-REF and OPERATION." - (etaf-view - (box :class "action" :ref host-ref :role 'button - :use (list (etaf-focusable)) - :on-press (lambda () - (etaf-dispatch 'etaf-counter-example-update - count operation)) - (text (expr :value label))))) - -(defun etaf-counter-example--actions (count) - "Return the action group for COUNT." - (etaf-view - (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) - (expr :value - (etaf-counter-example--action - count "− DECREMENT" 'counter-decrement 'decrement)) - (expr :value - (etaf-counter-example--action - count "RESET" 'counter-reset 'reset)) - (expr :value - (etaf-counter-example--action - count "+ INCREMENT" 'counter-increment 'increment))))) +(etaf-define-component etaf-counter-example-action + (&key count label operation) + "Render one semantic counter action." + :view + (box :class "action" :role 'button :use (list (etaf-focusable)) + :on-press + (let ((cell count) (next-operation operation)) + (lambda () + (etaf-dispatch 'etaf-counter-example-update + cell next-operation))) + (text (expr label))) + :styles + (styles + ("&" :flex-grow 1 :flex-shrink 1 :flex-basis (160) + :min-width (140) :padding (1 (12)) :border "#4E7890" + :bgcolor "#D9EAF2" :text-align center :font-weight bold))) (etaf-define-component etaf-counter-example-card (&key title initial-value) "Render a retained counter named TITLE starting at INITIAL-VALUE." - :styles - (styles - ("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE") - (".hero" :width (680) :padding (1 (18)) :border "#8F432F" - :bgcolor "#FFFDF8" :text-align center) - (".eyebrow" :color "#8F432F" :font-weight bold) - (".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200) - :min-width (180) :padding (1 (14)) :border "#6D8A73" - :bgcolor "#DCEBDD" :text-align center) - (".action" :flex-grow 1 :flex-shrink 1 :flex-basis (160) - :min-width (140) :padding (1 (12)) :border "#4E7890" - :bgcolor "#D9EAF2" :text-align center :font-weight bold) - (".note" :width (680) :padding (1 (16)) :border "#8D887F" - :color "#4D5651" :bgcolor "#EEEAE2")) :setup (let* ((count (etaf-ref (or initial-value 0) :name 'counter)) (double (etaf-computed @@ -95,19 +53,57 @@ (lambda () (if (zerop (etaf-value count)) "READY" "ACTIVE")) :name 'counter-status))) - (lambda () - (etaf-view - (column - (expr :value (etaf-counter-example--header title)) - (box :height 1) - (expr :value - (etaf-counter-example--metrics count double status)) - (box :height 1) - (expr :value (etaf-counter-example--actions count)) - (box :height 1) - (box :class "note" - (text - "Public path: Event → Action → Ref → Computed → Runtime commit"))))))) + (list :count count :double double :status status)) + :view + (column + (box :class "hero" + (column + (text :class "eyebrow" "BEST PRACTICE / RETAINED STATE") + (text :font-weight 'bold (expr title)) + (text :color "#66706A" + "State belongs to setup; rendering only reads it."))) + (box :height 1) + (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) + (box :class "metric" + (text (expr + (format "COUNT %d" + (etaf-value (plist-get (etaf-state) :count)))))) + (box :class "metric" + (text (expr + (format "DOUBLE %d" + (etaf-value (plist-get (etaf-state) :double)))))) + (box :class "metric" + (text (expr + (format "STATE %s" + (etaf-value (plist-get (etaf-state) :status))))))) + (box :height 1) + (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) + (etaf-counter-example-action + :ref 'counter-decrement + :count (plist-get (etaf-state) :count) + :label "− DECREMENT" :operation 'decrement) + (etaf-counter-example-action + :ref 'counter-reset + :count (plist-get (etaf-state) :count) + :label "RESET" :operation 'reset) + (etaf-counter-example-action + :ref 'counter-increment + :count (plist-get (etaf-state) :count) + :label "+ INCREMENT" :operation 'increment)) + (box :height 1) + (box :class "note" + (text "Public path: Event → Action → Ref → Computed → Runtime commit"))) + :styles + (styles + ("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE") + (".hero" :width (680) :padding (1 (18)) :border "#8F432F" + :bgcolor "#FFFDF8" :text-align center) + (".eyebrow" :color "#8F432F" :font-weight bold) + (".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200) + :min-width (180) :padding (1 (14)) :border "#6D8A73" + :bgcolor "#DCEBDD" :text-align center) + (".note" :width (680) :padding (1 (16)) :border "#8D887F" + :color "#4D5651" :bgcolor "#EEEAE2"))) ;;;###autoload (defun etaf-counter-example-view () diff --git a/examples/etaf-data-example.el b/examples/etaf-data-example.el index 797ff6a..1ce9baf 100644 --- a/examples/etaf-data-example.el +++ b/examples/etaf-data-example.el @@ -45,109 +45,53 @@ (etaf-data-set-query controller query) (etaf-data-load controller)) -(defun etaf-data-example--row (controller task) - "Return one TASK row bound to CONTROLLER." - (let* ((identity (plist-get task :id)) - (selected (etaf-data-selected-p controller identity)) - (status (plist-get task :status)) - (host-ref (intern (format "data-task-%d" identity)))) - (etaf-view - (flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10)) - :padding '(1 (12)) :border "#6D8A73" - :bgcolor (if selected "#DCEBDD" "#FFFDF8") - :ref host-ref :role 'button :use (list (etaf-focusable)) - :on-press (lambda () - (etaf-dispatch 'etaf-data-example-toggle - controller identity)) - (box :width '(36) :font-weight 'bold - :color (if selected "#2F6B43" "#8D887F") - (text (expr :value (if selected "●" "○")))) - (box :flex-grow 1 :flex-shrink 1 :flex-basis '(390) - :min-width '(280) - (text (expr :value (plist-get task :title)))) - (box :width '(96) :color "#66706A" - (text (expr :value (plist-get task :owner)))) - (box :width '(84) :font-weight 'bold :text-align 'right - :color (if (eq status 'done) "#2F6B43" "#9B4A34") - (text (expr :value (upcase (symbol-name status))))))))) - -(defun etaf-data-example--header (controller) - "Return the summary header for CONTROLLER." - (let ((total (etaf-value (etaf-data-total controller))) - (selection (etaf-value (etaf-data-selection controller)))) - (etaf-view - (box :width '(720) :padding '(1 (18)) :border "#8F432F" - :bgcolor "#FFFDF8" :text-align 'center - (column - (text :color "#8F432F" :font-weight 'bold - "BEST PRACTICE / DATA OWNERSHIP") - (text :font-weight 'bold "Task controller") - (text :color "#66706A" - (expr :value - (format "%d records · %d selected" total - (length selection))))))))) - -(defun etaf-data-example--filter-control - (controller label host-ref query border background) - "Return a filter LABEL for CONTROLLER using HOST-REF and QUERY. -Use BORDER and BACKGROUND for its semantic color family." - (etaf-view - (box :padding '(1 (12)) :border border :bgcolor background - :font-weight 'bold :ref host-ref :role 'button - :use (list (etaf-focusable)) - :on-press (lambda () - (etaf-data-example--filter controller query)) - (text (expr :value label))))) - -(defun etaf-data-example--toolbar (controller next-id) - "Return the action toolbar for CONTROLLER and NEXT-ID." - (etaf-view - (flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10)) - (expr :value (etaf-data-example--filter-control - controller "ALL" 'data-filter-all nil - "#4E7890" "#D9EAF2")) - (expr :value (etaf-data-example--filter-control - controller "OPEN" 'data-filter-open '(:status open) - "#C97252" "#F1D4C9")) - (expr :value (etaf-data-example--filter-control - controller "DONE" 'data-filter-done '(:status done) - "#6D8A73" "#DCEBDD")) - (box :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1" - :font-weight 'bold :ref 'data-add :role 'button - :use (list (etaf-focusable)) - :on-press (lambda () - (etaf-dispatch 'etaf-data-example-add - controller next-id)) - (text "+ ADD TASK"))))) - -(defun etaf-data-example--rows (controller) - "Return the loaded task rows for CONTROLLER." - (let ((items (etaf-value (etaf-data-items controller)))) - (if items - (mapcar (lambda (task) - (etaf-data-example--row controller task)) - items) - (etaf-view - (box :width '(720) :padding '(2 (16)) - :border "#8D887F" :bgcolor "#EEEAE2" - :text-align 'center - (text "No matching tasks.")))))) - -(defun etaf-data-example--view (controller next-id) - "Return the Data example View for CONTROLLER and NEXT-ID." - (etaf-view - (column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE" - (expr :value (etaf-data-example--header controller)) - (box :height 1) - (expr :value (etaf-data-example--toolbar controller next-id)) - (box :height 1) - (column :width '(720) - (expr :value (etaf-data-example--rows controller))) - (box :height 1) - (box :width '(720) :padding '(1 (16)) :border "#8D887F" - :color "#4D5651" :bgcolor "#EEEAE2" +(etaf-define-component etaf-data-example-row (&key controller task) + "Render one retained TASK row from CONTROLLER." + :view + (flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10)) + :padding '(1 (12)) :border "#6D8A73" + :bgcolor + (if (etaf-value + (etaf-data-selected-ref controller (plist-get task :id))) + "#DCEBDD" "#FFFDF8") + :role 'button :use (list (etaf-focusable)) + :on-press + (let ((data-controller controller) + (identity (plist-get task :id))) + (lambda () + (etaf-dispatch 'etaf-data-example-toggle + data-controller identity))) + (box :width '(36) :font-weight 'bold + :color + (if (etaf-value + (etaf-data-selected-ref controller (plist-get task :id))) + "#2F6B43" "#8D887F") (text - "Owner rule: create in setup, mutate through Data, stop on unmount"))))) + (expr + (if (etaf-value + (etaf-data-selected-ref controller (plist-get task :id))) + "●" "○")))) + (box :flex-grow 1 :flex-shrink 1 :flex-basis '(390) + :min-width '(280) + (text (expr (plist-get task :title)))) + (box :width '(96) :color "#66706A" + (text (expr (plist-get task :owner)))) + (box :width '(84) :font-weight 'bold :text-align 'right + :color (if (eq (plist-get task :status) 'done) + "#2F6B43" "#9B4A34") + (text (expr (upcase (symbol-name (plist-get task :status)))))))) + +(etaf-define-component etaf-data-example-filter + (&key controller label query border background) + "Render one query filter for CONTROLLER." + :view + (box :padding '(1 (12)) :border border :bgcolor background + :font-weight 'bold :role 'button :use (list (etaf-focusable)) + :on-press + (let ((data-controller controller) (next-query query)) + (lambda () + (etaf-data-example--filter data-controller next-query))) + (text (expr label)))) (etaf-define-component etaf-data-example-app () "Render a memory-backed task application with owned cleanup." @@ -161,7 +105,70 @@ Use BORDER and BACKGROUND for its semantic color family." (next-id (etaf-ref 6 :name 'etaf-data-example-next-id))) (etaf-on-mounted (lambda () (etaf-data-load controller))) (etaf-on-unmounted (lambda () (etaf-data-stop controller))) - (lambda () (etaf-data-example--view controller next-id)))) + (list :controller controller :next-id next-id)) + :view + (column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE" + (box :width '(720) :padding '(1 (18)) :border "#8F432F" + :bgcolor "#FFFDF8" :text-align 'center + (column + (text :color "#8F432F" :font-weight 'bold + "BEST PRACTICE / DATA OWNERSHIP") + (text :font-weight 'bold "Task controller") + (text :color "#66706A" + (expr + (format + "%d records · %d selected" + (etaf-value + (etaf-data-total (plist-get (etaf-state) :controller))) + (length + (etaf-value + (etaf-data-selection (plist-get (etaf-state) :controller))))))))) + (box :height 1) + (flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10)) + (etaf-data-example-filter + :ref 'data-filter-all + :controller (plist-get (etaf-state) :controller) + :label "ALL" :query nil :border "#4E7890" :background "#D9EAF2") + (etaf-data-example-filter + :ref 'data-filter-open + :controller (plist-get (etaf-state) :controller) + :label "OPEN" :query '(:status open) + :border "#C97252" :background "#F1D4C9") + (etaf-data-example-filter + :ref 'data-filter-done + :controller (plist-get (etaf-state) :controller) + :label "DONE" :query '(:status done) + :border "#6D8A73" :background "#DCEBDD") + (box :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1" + :font-weight 'bold :ref 'data-add :role 'button + :use (list (etaf-focusable)) + :on-press + (let ((controller (plist-get (etaf-state) :controller)) + (next-id (plist-get (etaf-state) :next-id))) + (lambda () + (etaf-dispatch 'etaf-data-example-add controller next-id))) + (text "+ ADD TASK"))) + (box :height 1) + (column :width '(720) + (box :if + (null + (etaf-value + (etaf-data-items (plist-get (etaf-state) :controller)))) + :width '(720) :padding '(2 (16)) + :border "#8D887F" :bgcolor "#EEEAE2" :text-align 'center + (text "No matching tasks.")) + (etaf-data-example-row + :for (task + (etaf-value + (etaf-data-items (plist-get (etaf-state) :controller)))) + :key (plist-get task :id) + :ref (intern (format "data-task-%d" (plist-get task :id))) + :controller (plist-get (etaf-state) :controller) + :task task)) + (box :height 1) + (box :width '(720) :padding '(1 (16)) :border "#8D887F" + :color "#4D5651" :bgcolor "#EEEAE2" + (text "Owner rule: create in setup, mutate through Data, stop on unmount")))) ;;;###autoload (defun etaf-data-example-view () diff --git a/examples/etaf-resource-example.el b/examples/etaf-resource-example.el index 7a14f6d..a85cad2 100644 --- a/examples/etaf-resource-example.el +++ b/examples/etaf-resource-example.el @@ -22,73 +22,6 @@ ('loading "Loading service snapshot…") (_ "Resource has not loaded."))) -(defun etaf-resource-example--header () - "Return the Resource example header." - (etaf-view - (box :width '(680) :padding '(1 (18)) :border "#8F432F" - :bgcolor "#FFFDF8" :text-align 'center - (column - (text :color "#8F432F" :font-weight 'bold - "BEST PRACTICE / RESOURCE LIFECYCLE") - (text :font-weight 'bold "Service health") - (text :color "#66706A" - "Loader errors become explicit state; cleanup stays scoped."))))) - -(defun etaf-resource-example--status (resource cleanup-count) - "Return the status card for RESOURCE and CLEANUP-COUNT." - (let* ((status (etaf-resource-status resource)) - (success (eq status 'success)) - (surface (if success "#DCEBDD" "#F1D4C9")) - (border (if success "#6D8A73" "#C97252")) - (ink (if success "#24422D" "#6B3020"))) - (etaf-view - (box :width '(680) :padding '(2 (18)) :border border - :bgcolor surface :color ink :text-align 'center - (column - (text :font-weight 'bold - (expr :value (upcase (symbol-name status)))) - (text (expr :value (etaf-resource-example--message resource))) - (text :color "#66706A" - (expr :value - (format "CLEANUPS %d" (etaf-value cleanup-count))))))))) - -(defun etaf-resource-example--actions (resource fail-next) - "Return action controls for RESOURCE and FAIL-NEXT." - (etaf-view - (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) - (box :flex-grow 1 :flex-shrink 1 :flex-basis '(200) - :min-width '(180) :padding '(1 (12)) - :border "#4E7890" :bgcolor "#D9EAF2" :font-weight 'bold - :text-align 'center :ref 'resource-reload :role 'button - :use (list (etaf-focusable)) - :on-press (lambda () (etaf-resource-load resource)) - (text "RELOAD")) - (box :flex-grow 1 :flex-shrink 1 :flex-basis '(200) - :min-width '(180) :padding '(1 (12)) - :border "#C97252" :bgcolor "#F1D4C9" :font-weight 'bold - :text-align 'center :ref 'resource-fail :role 'button - :use (list (etaf-focusable)) - :on-press (lambda () - (etaf-set-value fail-next t) - (etaf-resource-load resource)) - (text "SIMULATE FAILURE"))))) - -(defun etaf-resource-example--view (resource fail-next cleanup-count) - "Return the example View for RESOURCE, FAIL-NEXT, and CLEANUP-COUNT." - (etaf-view - (column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE" - (expr :value (etaf-resource-example--header)) - (box :height 1) - (expr :value - (etaf-resource-example--status resource cleanup-count)) - (box :height 1) - (expr :value (etaf-resource-example--actions resource fail-next)) - (box :height 1) - (box :width '(680) :padding '(1 (16)) :border "#8D887F" - :color "#4D5651" :bgcolor "#EEEAE2" - (text - "Scope rule: reload releases the old value; unmount releases the last one"))))) - (etaf-define-component etaf-resource-example-app () "Render a reloadable Resource with visible cleanup and error state." :setup @@ -114,8 +47,75 @@ :immediate nil :name 'etaf-resource-example)) (etaf-on-mounted (lambda () (etaf-resource-load resource))) - (lambda () - (etaf-resource-example--view resource fail-next cleanup-count)))) + (list :resource resource :fail-next fail-next + :cleanup-count cleanup-count)) + :view + (column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE" + (box :width '(680) :padding '(1 (18)) :border "#8F432F" + :bgcolor "#FFFDF8" :text-align 'center + (column + (text :color "#8F432F" :font-weight 'bold + "BEST PRACTICE / RESOURCE LIFECYCLE") + (text :font-weight 'bold "Service health") + (text :color "#66706A" + "Loader errors become explicit state; cleanup stays scoped."))) + (box :height 1) + (box :width '(680) :padding '(2 (18)) + :border + (if (eq (etaf-resource-status + (plist-get (etaf-state) :resource)) 'success) + "#6D8A73" "#C97252") + :bgcolor + (if (eq (etaf-resource-status + (plist-get (etaf-state) :resource)) 'success) + "#DCEBDD" "#F1D4C9") + :color + (if (eq (etaf-resource-status + (plist-get (etaf-state) :resource)) 'success) + "#24422D" "#6B3020") + :text-align 'center + (column + (text :font-weight 'bold + (expr + (upcase + (symbol-name + (etaf-resource-status (plist-get (etaf-state) :resource)))))) + (text + (expr + (etaf-resource-example--message + (plist-get (etaf-state) :resource)))) + (text :color "#66706A" + (expr + (format "CLEANUPS %d" + (etaf-value (plist-get (etaf-state) :cleanup-count))))))) + (box :height 1) + (flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12)) + (box :flex-grow 1 :flex-shrink 1 :flex-basis '(200) + :min-width '(180) :padding '(1 (12)) + :border "#4E7890" :bgcolor "#D9EAF2" :font-weight 'bold + :text-align 'center :ref 'resource-reload :role 'button + :use (list (etaf-focusable)) + :on-press + (let ((resource (plist-get (etaf-state) :resource))) + (lambda () (etaf-resource-load resource))) + (text "RELOAD")) + (box :flex-grow 1 :flex-shrink 1 :flex-basis '(200) + :min-width '(180) :padding '(1 (12)) + :border "#C97252" :bgcolor "#F1D4C9" :font-weight 'bold + :text-align 'center :ref 'resource-fail :role 'button + :use (list (etaf-focusable)) + :on-press + (let ((resource (plist-get (etaf-state) :resource)) + (fail-next (plist-get (etaf-state) :fail-next))) + (lambda () + (etaf-set-value fail-next t) + (etaf-resource-load resource))) + (text "SIMULATE FAILURE"))) + (box :height 1) + (box :width '(680) :padding '(1 (16)) :border "#8D887F" + :color "#4D5651" :bgcolor "#EEEAE2" + (text + "Scope rule: reload releases the old value; unmount releases the last one")))) ;;;###autoload (defun etaf-resource-example-view () diff --git a/scripts/etaf-m0a-inventory.el b/scripts/etaf-m0a-inventory.el new file mode 100644 index 0000000..ad8838b --- /dev/null +++ b/scripts/etaf-m0a-inventory.el @@ -0,0 +1,315 @@ +;;; etaf-m0a-inventory.el --- M0a current-contract inventory -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;;; Commentary: + +;; This is a read-only M0a inventory surface. It records current contracts, +;; known pre-activation baselines, and the condition handlers present in ETAF +;; source files. It intentionally does not turn future architecture targets +;; into passing assertions. + +;;; Code: + +(require 'cl-lib) +(require 'etaf) +(require 'json) +(require 'macroexp) + +(defconst etaf-m0a-package-root + (file-name-directory + (directory-file-name + (file-name-directory (or load-file-name buffer-file-name)))) + "Absolute ETAF package root inferred when this inventory is loaded.") + +(defconst etaf-m0a-current-contract-inventory + '((:id component-definition + :evidence-mode current-contract + :summary ":view or :render is required; :setup/:styles are optional" + :tests (etaf-component-frontends-definition-boundary-is-strict + etaf-component-definition-keywords-have-one-owner)) + (:id host-attrs + :evidence-mode current-contract + :summary "undeclared Host attrs fall through a single-root Component chain" + :tests (etaf-component-host-attrs-fall-through-one-root-chain + etaf-component-host-attrs-reject-ambiguous-or-invalid-targets + etaf-component-host-attrs-rollback-root-shape-failure)) + (:id slots-key-lifecycle-rollback + :evidence-mode current-contract + :summary "slots retain caller ownership; key is framework-owned; lifecycle and rollback are ordered" + :tests (etaf-component-frontends-project-default-and-named-slots + etaf-component-key-is-framework-owned-and-render-result-is-typed + etaf-component-lifecycle-and-scope-cleanup-are-ordered + etaf-component-render-side-effect-rolls-back-completely)) + (:id action-registration + :evidence-mode observed-baseline + :activation-milestone M0b + :owner etaf-actions + :summary "registering an existing Action name replaces the current spec" + :tests (etaf-m0a-action-registration-replaces-current-definition)) + (:id behavior-duplicates + :evidence-mode observed-baseline + :activation-milestone M0b + :owner etaf-runtime + :summary "same-name Behaviors are currently processed in declaration order; no pre-install duplicate gate exists" + :tests (etaf-runtime-composes-host-and-behavior-events-in-order + etaf-behavior-replacement-disposes-previous-installer)) + (:id event-rules + :evidence-mode current-contract + :summary "event names normalize keyword/symbol/string on-* spellings; Host callback precedes Behavior callback" + :tests (etaf-m0a-event-kind-normalizes-current-spellings + etaf-runtime-composes-host-and-behavior-events-in-order)) + (:id dependency-only-publication + :evidence-mode current-contract + :summary "semantic generation advances without Ebox commit or TP surface revision" + :tests (etaf-m0a-dependency-only-skips-ebox-and-tp-publication)) + (:id initial-attach + :evidence-mode current-contract + :summary "initial observed publication reports TP, Ebox, then ETAF" + :tests (etaf-runtime-observer-covers-initial-publication)) + (:id unmount-kill + :evidence-mode current-contract + :summary "unmount disposes lifecycle before scope cleanup; kill follows unmount; repeated public unmount signals" + :tests (etaf-component-lifecycle-and-scope-cleanup-are-ordered + etaf-runtime-killed-buffer-unmounts-owned-scope + etaf-m0a-repeated-public-unmount-signals-runtime-error)) + (:id condition-trailer + :evidence-mode observed-baseline + :activation-milestone M3a + :owner etaf-runtime + :summary "current consumers receive raw condition symbols/data; typed compatibility trailer is not active" + :tests (etaf-m0a-public-update-preserves-raw-condition-symbol-and-data)) + (:id document-examples + :evidence-mode observed-baseline + :activation-milestone M0b + :owner etaf-documentation + :summary "all user-facing fenced Elisp blocks have reviewed read, macroexpand, load-safety, and drift outcomes" + :tests (etaf-m0a-document-example-inventory-matches-reviewed-golden))) + "Machine-readable M0a ledger for ETAF current behavior and future gates.") + +(defconst etaf-m0a-document-example-files + '("README.md" + "README.zh-CN.md" + "examples/README.md" + "examples/README.zh-CN.md" + "docs/architecture.en.md" + "docs/architecture.zh.md" + "docs/user-guide.en.md" + "docs/user-guide.zh.md" + "docs/implementation-plan.en.md" + "docs/implementation-plan.zh.md") + "User-facing documents whose fenced Elisp blocks belong to M0a inventory.") + +(defun etaf-m0a--condition-handler-symbols (clause) + "Return the condition symbols handled by `condition-case' CLAUSE." + (let ((head (car-safe clause))) + (cond + ((symbolp head) (list head)) + ((proper-list-p head) (cl-remove-if-not #'symbolp head)) + (t nil)))) + +(defun etaf-m0a--condition-policy (conditions) + "Return the current handling policy for CONDITIONS." + (if (cl-every (lambda (condition) (memq condition '(error quit))) conditions) + 'generic-containment + 'specific-compatibility)) + +(defun etaf-m0a--walk-condition-consumers (form file line) + "Return condition consumer records below FORM from FILE at LINE." + (let (records) + (when (consp form) + (unless (memq (car form) '(quote function)) + (when (memq (car form) '(condition-case condition-case-unless-debug)) + (dolist (clause (cdddr form)) + (let ((conditions (etaf-m0a--condition-handler-symbols clause))) + (when conditions + (push (list :file file :line line :form (car form) + :conditions conditions + :owner (intern (file-name-base file)) + :policy (etaf-m0a--condition-policy conditions)) + records))))) + (setq records + (nconc records + (etaf-m0a--walk-condition-consumers + (car form) file line) + (etaf-m0a--walk-condition-consumers + (cdr form) file line))))) + records)) + +(defun etaf-m0a-condition-consumer-inventory (&optional directory) + "Return condition consumers in top-level ETAF sources under DIRECTORY. + +DIRECTORY defaults to the package root inferred from this script. Test and +example files are excluded so this inventory describes product consumers." + (let* ((root (file-name-as-directory + (expand-file-name + (or directory etaf-m0a-package-root)))) + (files (sort (directory-files root t "\\`etaf-.*\\.el\\'") + #'string<)) + records) + (dolist (file files) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (condition-case nil + (while t + (let ((line (line-number-at-pos)) + (form (read (current-buffer)))) + (setq records + (nconc records + (etaf-m0a--walk-condition-consumers + form (file-relative-name file root) line))))) + (end-of-file nil)))) + (sort records + (lambda (left right) + (or (string< (plist-get left :file) (plist-get right :file)) + (and (equal (plist-get left :file) (plist-get right :file)) + (< (plist-get left :line) (plist-get right :line)))))))) + +(defun etaf-m0a-condition-consumer-signatures (&optional directory) + "Return stable golden signatures for source consumers under DIRECTORY. + +Line numbers remain available in the diagnostic inventory but are excluded +from this signature so unrelated line movement does not rewrite the golden." + (mapcar + (lambda (entry) + (list :file (plist-get entry :file) + :form (plist-get entry :form) + :conditions (plist-get entry :conditions) + :owner (plist-get entry :owner) + :policy (plist-get entry :policy))) + (etaf-m0a-condition-consumer-inventory directory))) + +(defun etaf-m0a--document-elisp-blocks (file root) + "Return fenced Elisp blocks from FILE below ROOT." + (with-temp-buffer + (insert-file-contents (expand-file-name file root)) + (goto-char (point-min)) + (let ((index 0) blocks) + (while (re-search-forward "^```elisp[[:space:]]*$" nil t) + (let ((line (line-number-at-pos)) + (start (line-beginning-position 2))) + (unless (re-search-forward "^```[[:space:]]*$" nil t) + (error "Unclosed Elisp block in %s" file)) + (cl-incf index) + (push (list :index index :line line + :source (buffer-substring-no-properties + start (match-beginning 0))) + blocks))) + (nreverse blocks)))) + +(defun etaf-m0a--read-document-forms (source) + "Read all forms from documentation SOURCE and return a result plist." + (with-temp-buffer + (emacs-lisp-mode) + (insert source) + (goto-char (point-min)) + (let (forms failure) + (condition-case condition + (while (progn + (skip-chars-forward " \t\r\n") + (< (point) (point-max))) + (push (read (current-buffer)) forms)) + (error (setq failure (car condition)))) + (if failure + (list :status 'error :detail failure :forms nil) + (list :status 'ok :detail (length forms) :forms (nreverse forms)))))) + +(defun etaf-m0a--macroexpand-document-forms (forms) + "Macroexpand FORMS and return a stable outcome plist." + (condition-case condition + (progn + (mapc #'macroexpand-all forms) + (list :status 'ok :detail (length forms))) + (error (list :status 'error :detail (car condition))))) + +(defun etaf-m0a-document-example-inventory (&optional directory) + "Return current read/macroexpand/load outcomes for user documentation. + +DIRECTORY defaults to `etaf-m0a-package-root'. +Arbitrary documentation code is never evaluated in the agent process: it may +mount buffers, mutate files, start async work, or depend on user state. Every +block therefore has an explicit skipped load outcome and safety reason." + (let ((root (file-name-as-directory + (expand-file-name (or directory etaf-m0a-package-root))))) + (mapcar + (lambda (file) + (list + :file file + :blocks + (mapcar + (lambda (block) + (let* ((source (plist-get block :source)) + (read-result (etaf-m0a--read-document-forms source)) + (macro-result + (if (eq 'ok (plist-get read-result :status)) + (etaf-m0a--macroexpand-document-forms + (plist-get read-result :forms)) + (list :status 'skipped :detail 'read-failed))) + (drift + (cond + ((eq 'error (plist-get read-result :status)) 'read-error) + ((eq 'error (plist-get macro-result :status)) + 'macroexpand-error) + (t 'none)))) + (list :index (plist-get block :index) + :line (plist-get block :line) + :sha256 (secure-hash 'sha256 source) + :read-status (plist-get read-result :status) + :read-detail (plist-get read-result :detail) + :macroexpand-status (plist-get macro-result :status) + :macroexpand-detail (plist-get macro-result :detail) + :load-status 'skipped-unsafe + :load-reason 'arbitrary-document-code + :drift drift))) + (etaf-m0a--document-elisp-blocks file root)))) + etaf-m0a-document-example-files))) + +(defun etaf-m0a-document-example-signatures (&optional directory) + "Return stable golden signatures for documentation under DIRECTORY." + (mapcar + (lambda (file-entry) + (list + :file (plist-get file-entry :file) + :blocks + (mapcar + (lambda (block) + (list (plist-get block :index) + (plist-get block :sha256) + (plist-get block :read-status) + (plist-get block :read-detail) + (plist-get block :macroexpand-status) + (plist-get block :macroexpand-detail) + (plist-get block :load-status) + (plist-get block :load-reason) + (plist-get block :drift))) + (plist-get file-entry :blocks)))) + (etaf-m0a-document-example-inventory directory))) + +(defun etaf-m0a-inventory-json (&optional directory) + "Return the current M0a ledger and condition inventory as JSON. + +DIRECTORY is forwarded to `etaf-m0a-condition-consumer-inventory'." + (json-encode + (list :schema-version 1 + :contract-inventory (vconcat etaf-m0a-current-contract-inventory) + :condition-consumers + (vconcat (etaf-m0a-condition-consumer-inventory directory)) + :document-examples + (vconcat + (mapcar + (lambda (entry) + (let ((copy (copy-sequence entry))) + (plist-put copy :blocks + (vconcat (plist-get copy :blocks))))) + (etaf-m0a-document-example-inventory directory)))))) + +(when noninteractive + (when (member "--etaf-m0a-print-inventory" command-line-args-left) + (setq command-line-args-left + (delete "--etaf-m0a-print-inventory" command-line-args-left)) + (princ (etaf-m0a-inventory-json)) + (terpri))) + +(provide 'etaf-m0a-inventory) +;;; etaf-m0a-inventory.el ends here diff --git a/tests/etaf-interaction-contract-tests.el b/tests/etaf-interaction-contract-tests.el new file mode 100644 index 0000000..709abcd --- /dev/null +++ b/tests/etaf-interaction-contract-tests.el @@ -0,0 +1,284 @@ +;;; etaf-interaction-contract-tests.el --- Interaction contract tests -*- lexical-binding: t; -*- + +;; SPDX-License-Identifier: GPL-3.0-or-later + +;;; Commentary: + +;; Lock the M0b Action, Behavior, and local event composition contract. + +;;; Code: + +(require 'ert) +(require 'etaf) + +(defun etaf-interaction-test--dispose-buffer (buffer-name) + "Unmount and kill BUFFER-NAME when either still exists." + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))) + +(ert-deftest etaf-interaction-duplicate-behavior-fails-before-install () + "Reject duplicate names on one Host without running either installer." + (let ((buffer-name " *etaf-duplicate-behavior-contract*") + (installs 0)) + (unwind-protect + (let ((first + (etaf-behavior-create + 'duplicate + :install (lambda () (cl-incf installs) #'ignore))) + (second + (etaf-behavior-create + 'duplicate + :install (lambda () (cl-incf installs) #'ignore)))) + (should-error + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text (list :ref 'target :use (list first second)) + (list "target")))) + :type 'etaf-behavior-error) + (should (zerop installs))) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-interaction-behaviors-compose-in-declaration-order () + "Preserve installer/event order, first-wins props, and one cleanup each." + (let ((buffer-name " *etaf-behavior-order-contract*") + install-order event-order cleanup-counts) + (unwind-protect + (let* ((first + (etaf-behavior-create + 'first + :class "first" + :on-press (lambda () (setq event-order + (append event-order '(first)))) + :install (lambda () + (setq install-order (append install-order '(first))) + (lambda () (push 'first cleanup-counts))))) + (second + (etaf-behavior-create + 'second + :class "second" + :on-press (lambda () (setq event-order + (append event-order '(second)))) + :install (lambda () + (setq install-order (append install-order '(second))) + (lambda () (push 'second cleanup-counts)))))) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text + (list :ref 'target :use (list first second) + :on-press + (lambda () (setq event-order (append event-order '(host))))) + (list "target")))) + (let ((runtime (etaf-runtime-for-buffer buffer-name))) + (should (equal install-order '(first second))) + (should (equal (plist-get + (etaf-runtime-host-props-for runtime 'target) + :class) + "first")) + (etaf-dispatch-event runtime 'target 'press) + (should (equal event-order '(host first second))) + (etaf-unmount runtime)) + (should (= 1 (cl-count 'first cleanup-counts))) + (should (= 1 (cl-count 'second cleanup-counts)))) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-interaction-callback-failure-short-circuits-behaviors () + "Stop Behavior callbacks after an earlier callback signals." + (let ((buffer-name " *etaf-behavior-failure-contract*") trace) + (unwind-protect + (let ((first + (etaf-behavior-create + 'first :on-press + (lambda () (push 'first trace) (error "first failed")))) + (second + (etaf-behavior-create + 'second :on-press (lambda () (push 'second trace))))) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text + (list :ref 'target :use (list first second) + :on-press (lambda () (push 'host trace) (error "host failed"))) + (list "target")))) + (should-error + (etaf-dispatch-event (etaf-runtime-for-buffer buffer-name) + 'target 'press)) + (should (equal trace '(host))) + (etaf-unmount (etaf-runtime-for-buffer buffer-name)) + (setq trace nil) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text + (list :ref 'target :use (list first second) + :on-press (lambda () (push 'host trace))) + (list "target")))) + (should-error + (etaf-dispatch-event (etaf-runtime-for-buffer buffer-name) + 'target 'press)) + (should (equal trace '(first host)))) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-interaction-stable-installer-identity-cleans-up-once () + "Reuse an identical installer and run its cleanup exactly once." + (let ((buffer-name " *etaf-behavior-identity-contract*") + (trigger (etaf-ref 0)) + (installs 0) + (cleanups 0)) + (unwind-protect + (let* ((installer + (lambda () + (cl-incf installs) + (lambda () (cl-incf cleanups)))) + (behavior + (etaf-behavior-create 'stable :install installer))) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text + (list :ref 'target :use behavior + :aria-label (format "version-%d" (etaf-value trigger))) + (list "target")))) + (should (= installs 1)) + (setf (etaf-value trigger) 1) + (should (= installs 1)) + (should (zerop cleanups)) + (etaf-unmount (etaf-runtime-for-buffer buffer-name)) + (should (= cleanups 1))) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-interaction-events-do-not-capture-or-bubble () + "Dispatch only the callback owned by the exact Host reference." + (let ((buffer-name " *etaf-local-event-contract*") trace) + (unwind-protect + (progn + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'column + (list :ref 'parent :on-press (lambda () (push 'parent trace))) + (list + (etaf--view-call + 'text + (list :ref 'child :on-press (lambda () (push 'child trace))) + (list "child")))))) + (let ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-dispatch-event runtime 'child 'press) + (should (equal trace '(child))) + (setq trace nil) + (etaf-dispatch-event runtime 'parent 'press) + (should (equal trace '(parent))))) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-action-duplicate-registration-errors-by-default () + "Keep the first Action when another application claims the same name." + (let ((name 'etaf-interaction-test-cross-app-action) + (first (lambda (_runtime) 'first)) + (second (lambda (_runtime) 'second))) + (unwind-protect + (progn + (etaf-action-register name first) + (should-error (etaf-action-register name second) + :type 'etaf-action-error) + (should (eq first + (etaf-action-spec-function + (gethash name etaf--action-registry))))) + (etaf-action-undefine name)))) + +(ert-deftest etaf-action-redefine-boundary-affects-only-future-dispatch () + "Replace name lookup explicitly without flushing a mounted Runtime." + (let ((buffer-name " *etaf-action-redefine-contract*") + (name 'etaf-interaction-test-future-action) + (first-calls 0) + (second-calls 0)) + (unwind-protect + (progn + (etaf-action-register + name (lambda (_runtime) (cl-incf first-calls))) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'text + (list :ref 'target + :on-press (lambda () (etaf-dispatch name))) + (list "target")))) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (generation (etaf-runtime-current-generation runtime))) + (etaf-dispatch-event runtime 'target 'press) + (should (= first-calls 1)) + (etaf-action-redefine-run + (lambda () + (etaf-action-register + name (lambda (_runtime) (cl-incf second-calls))))) + (should (eq generation + (etaf-runtime-current-generation runtime))) + (should (= first-calls 1)) + (should (zerop second-calls)) + (etaf-dispatch-event runtime 'target 'press) + (should (= second-calls 1)))) + (etaf-action-undefine name) + (etaf-interaction-test--dispose-buffer buffer-name)))) + +(ert-deftest etaf-action-reload-requires-explicit-redefine-boundary () + "Make repeated authoring definitions explicit and dynamically scoped." + (let ((name 'etaf-interaction-test-reload-action) + (function-symbol 'etaf-interaction-test-reload-action--etaf-action)) + (unwind-protect + (progn + (eval '(etaf-action-define etaf-interaction-test-reload-action + (_runtime) + 'first) + t) + (should-error + (eval '(etaf-action-define etaf-interaction-test-reload-action + (_runtime) + 'unintended) + t) + :type 'etaf-action-error) + (should + (eq 'first + (funcall + (etaf-action-spec-function + (gethash name etaf--action-registry)) + nil))) + (etaf-action-redefine-run + (lambda () + (eval '(etaf-action-define etaf-interaction-test-reload-action + (_runtime) + 'second) + t))) + (should + (eq 'second + (funcall + (etaf-action-spec-function + (gethash name etaf--action-registry)) + nil))) + (should-error + (eval '(etaf-action-define etaf-interaction-test-reload-action + (_runtime) + 'unintended) + t) + :type 'etaf-action-error) + (should + (eq 'second + (funcall + (etaf-action-spec-function + (gethash name etaf--action-registry)) + nil)))) + (etaf-action-undefine name) + (when (fboundp function-symbol) + (fmakunbound function-symbol))))) + +(provide 'etaf-interaction-contract-tests) + +;;; etaf-interaction-contract-tests.el ends here diff --git a/tests/etaf-m0a-current-characterization-tests.el b/tests/etaf-m0a-current-characterization-tests.el new file mode 100644 index 0000000..2503601 --- /dev/null +++ b/tests/etaf-m0a-current-characterization-tests.el @@ -0,0 +1,201 @@ +;;; etaf-m0a-current-characterization-tests.el --- M0a ETAF baseline -*- lexical-binding: t; -*- + +;;; Code: + +(require 'ert) +(require 'etaf) +(require 'etaf-m0a-inventory) + +(define-error 'etaf-test-m0a-lifecycle-condition + "M0a lifecycle characterization condition") + +(defconst etaf-test-m0a-condition-data + '(:phase updated + :payload ((account-id . 42) (tags alpha beta)) + :retryable nil) + "Non-trivial raw condition data used by the M0a public update probe.") + +(etaf-define-component etaf-test-m0a-dependency-only (&key source) + "Observe SOURCE while retaining equal rendered output." + :view (text (expr (progn (etaf-value source) "same")))) + +(etaf-define-component etaf-test-m0a-lifecycle-failure (&key label) + "Publish LABEL, then signal a custom condition from the update lifecycle." + :setup + (progn + (etaf-on-updated + (lambda () + (signal 'etaf-test-m0a-lifecycle-condition + etaf-test-m0a-condition-data))) + nil) + :view (text (expr label))) + +(ert-deftest etaf-m0a-action-registration-requires-explicit-redefinition () + "Duplicate Action registration fails outside the authoring boundary." + (let* ((name (make-symbol "etaf-m0a-action")) + (first (lambda (_runtime) 'first)) + (second (lambda (_runtime) 'second))) + (unwind-protect + (progn + (etaf-action-register name first) + (should-error (etaf-action-register name second) + :type 'etaf-action-error) + (should (eq first + (etaf-action-spec-function + (gethash name etaf--action-registry)))) + (etaf-action-redefine-run + (lambda () (etaf-action-register name second))) + (should (eq second + (etaf-action-spec-function + (gethash name etaf--action-registry))))) + (etaf-action-undefine name)))) + +(ert-deftest etaf-m0a-event-kind-normalizes-current-spellings () + "Keyword, symbol, and string event spellings normalize to one symbol." + (dolist (spelling '(:press press on-press "press" "on-press")) + (should (eq 'press (etaf-event-kind spelling))))) + +(ert-deftest etaf-m0a-dependency-only-skips-ebox-and-tp-publication () + "An equal-output dependency update advances ETAF only, not Ebox or TP." + (let ((buffer-name " *etaf-m0a-dependency-only*") + (source (etaf-ref 0)) + (ebox-commits 0)) + (unwind-protect + (progn + (etaf-mount + buffer-name + (etaf-view (etaf-test-m0a-dependency-only :source source))) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (surface (with-current-buffer buffer-name + (car tp--buffer-surfaces))) + (generation (etaf-runtime-generation runtime)) + (revision (tp-surface-revision surface)) + (original-ebox-commit (symbol-function 'ebox-commit))) + (cl-letf (((symbol-function 'ebox-commit) + (lambda (&rest arguments) + (cl-incf ebox-commits) + (apply original-ebox-commit arguments)))) + (setf (etaf-value source) 1)) + (should (= (1+ generation) (etaf-runtime-generation runtime))) + (should (zerop ebox-commits)) + (should (= revision (tp-surface-revision surface))))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-m0a-repeated-public-unmount-signals-runtime-error () + "Calling the public unmount boundary twice signals runtime error." + (let ((buffer-name " *etaf-m0a-repeated-unmount*") runtime) + (unwind-protect + (progn + (etaf-mount buffer-name (etaf-view (text "mounted"))) + (setq runtime (etaf-runtime-for-buffer buffer-name)) + (etaf-unmount runtime) + (should-error (etaf-unmount runtime) :type 'etaf-runtime-error)) + (when (and runtime (etaf-runtime-mounted-p runtime)) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-m0a-public-update-preserves-raw-condition-symbol-and-data () + "A public update exposes the exact lifecycle condition symbol and payload." + (let ((buffer-name " *etaf-m0a-lifecycle-condition*") + (label (etaf-ref "A")) + captured) + (unwind-protect + (progn + (etaf-mount + buffer-name + (lambda () + (etaf-view + (etaf-test-m0a-lifecycle-failure + :label (etaf-value label))))) + (condition-case condition + (setf (etaf-value label) "B") + (etaf-test-m0a-lifecycle-condition + (setq captured condition))) + (should + (equal captured + (cons 'etaf-test-m0a-lifecycle-condition + etaf-test-m0a-condition-data))) + (should (equal "B" + (with-current-buffer buffer-name + (buffer-string))))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) + (kill-buffer buffer))))) + +(ert-deftest etaf-m0a-condition-consumer-inventory-is-machine-readable () + "The source consumer inventory exactly matches its reviewed golden." + (let ((consumers (etaf-m0a-condition-consumer-inventory)) + (golden-file + (expand-file-name "tests/fixtures/etaf-m0a-condition-consumers.sexp" + etaf-m0a-package-root))) + (should consumers) + (should (cl-find "etaf-runtime.el" consumers + :key (lambda (entry) (plist-get entry :file)) + :test #'equal)) + (should (cl-every (lambda (entry) + (and (stringp (plist-get entry :file)) + (integerp (plist-get entry :line)) + (symbolp (plist-get entry :form)) + (proper-list-p (plist-get entry :conditions)) + (symbolp (plist-get entry :owner)) + (memq (plist-get entry :policy) + '(generic-containment + specific-compatibility)))) + consumers)) + (with-temp-buffer + (insert-file-contents golden-file) + (should (equal (read (current-buffer)) + (etaf-m0a-condition-consumer-signatures))) + (skip-chars-forward " \t\r\n") + (should (eobp))) + (should (cl-find 'observed-baseline + etaf-m0a-current-contract-inventory + :key (lambda (entry) + (plist-get entry :evidence-mode)))) + (let ((json (json-parse-string (etaf-m0a-inventory-json)))) + (should (= 1 (gethash "schema-version" json))) + (should (= (length etaf-m0a-current-contract-inventory) + (length (gethash "contract-inventory" json)))) + (should (= (length consumers) + (length (gethash "condition-consumers" json)))) + (should (= (length etaf-m0a-document-example-files) + (length (gethash "document-examples" json))))))) + +(ert-deftest etaf-m0a-document-example-inventory-matches-reviewed-golden () + "Every user documentation block matches its reviewed M0a outcome." + (let* ((golden-file + (expand-file-name "tests/fixtures/etaf-m0a-document-examples.sexp" + etaf-m0a-package-root)) + (inventory (etaf-m0a-document-example-inventory)) + (blocks (apply #'append + (mapcar (lambda (entry) + (plist-get entry :blocks)) + inventory))) + golden) + (with-temp-buffer + (insert-file-contents golden-file) + (setq golden (read (current-buffer))) + (skip-chars-forward " \t\r\n") + (should (eobp))) + (should (equal golden (etaf-m0a-document-example-signatures))) + (should (= 122 (length blocks))) + (should (= 0 (cl-count 'read-error blocks + :key (lambda (entry) + (plist-get entry :drift))))) + (should (= 4 (cl-count 'macroexpand-error blocks + :key (lambda (entry) + (plist-get entry :drift))))) + (should (cl-every + (lambda (entry) + (and (eq 'skipped-unsafe (plist-get entry :load-status)) + (eq 'arbitrary-document-code + (plist-get entry :load-reason)))) + blocks)))) + +(provide 'etaf-m0a-current-characterization-tests) +;;; etaf-m0a-current-characterization-tests.el ends here diff --git a/tests/etaf-tests.el b/tests/etaf-tests.el index c7a7e68..3f583a2 100644 --- a/tests/etaf-tests.el +++ b/tests/etaf-tests.el @@ -55,6 +55,8 @@ (defvar etaf-test-nested-range-present nil) (defvar etaf-test-nested-range-source nil) (defvar etaf-test-nested-range-evals 0) +(defvar etaf-test-nested-outer-source nil) +(defvar etaf-test-nested-inner-source nil) (defvar etaf-test-inline-shared nil) (defvar etaf-test-inline-shared-evals 0) (defvar etaf-test-inline-branch-mode nil) @@ -193,7 +195,7 @@ (etaf-define-component etaf-test-retained-leaf (&key label cell) "Render one independently reactive retained leaf." :view - (text (expr :value (etaf-test--retained-leaf-value label cell)))) + (text (expr (etaf-test--retained-leaf-value label cell)))) (etaf-define-component etaf-test-setup-read-owner (&key setup-source render-source) @@ -201,25 +203,24 @@ :setup (progn (etaf-value setup-source) - (lambda () - (etaf-view (text (expr :value (etaf-value render-source))))))) + render-source) + :render + (etaf-node 'text nil (list (etaf-value (etaf-state))))) (etaf-define-component etaf-test-dependency-only (&key source) "Track SOURCE while returning semantically equal output." :view - (text (expr :value (progn (etaf-value source) "same")))) + (text (expr (progn (etaf-value source) "same")))) (etaf-define-component etaf-test-input-equal (&key label) "Count renders of a caller-owned semantic input." :view - (text (expr :value - (progn (cl-incf etaf-test-input-render-count) label)))) + (text (expr (progn (cl-incf etaf-test-input-render-count) label)))) (etaf-define-component etaf-test-target-priority (&key label) "Render LABEL with an independently dirty render dependency." :view - (text (expr :value - (progn + (text (expr (progn (cl-incf etaf-test-priority-render-count) (format "%s/%s" label (etaf-value etaf-test-priority-render-source)))))) @@ -231,7 +232,7 @@ :view (etaf-test-styled-slot-child (text :class "live" - (expr :value (etaf-value etaf-test-local-style-source))))) + (expr (etaf-value etaf-test-local-style-source))))) (etaf-define-component etaf-test-lazy-computed-owner () "Create a lazy computed first evaluated by the render target." @@ -240,30 +241,31 @@ (computed (etaf-computed (lambda () (* 2 (etaf-value base)))))) (setq etaf-test-lazy-computed-base base etaf-test-lazy-computed-value computed) - (lambda () - (etaf-view (text (expr :value (number-to-string - (etaf-value computed)))))))) + computed) + :render + (etaf-node 'text nil + (list (number-to-string (etaf-value (etaf-state)))))) (etaf-define-component etaf-test-wide-parent () "Render a wide stable child list around one parent-owned value." :setup - (lambda () - (etaf--view-call + (list etaf-test-wide-parent-source etaf-test-wide-parent-cells) + :render + (let ((source (car (etaf-state))) (cells (cadr (etaf-state)))) + (etaf-node 'column nil - (cons - (etaf--view-call - 'text nil (list (format "parent=%s" - (etaf-value etaf-test-wide-parent-source)))) - (cl-loop for cell in etaf-test-wide-parent-cells for index from 0 - collect - (etaf--view-call 'etaf-test-retained-leaf - (list :key index :label index :cell cell) - nil)))))) + (cons (etaf-node 'text nil + (list (format "parent=%s" (etaf-value source)))) + (cl-loop for cell in cells for index from 0 + collect + (etaf-node 'etaf-test-retained-leaf + (list :key index :label index :cell cell) + nil)))))) (etaf-define-component etaf-test-direct-range () "Render static siblings and one direct retained material-child Range." :setup - (let ((range (etaf--expr-create + (let ((range (etaf--expr-create :token 'etaf-test-direct-range-site :thunk #'etaf-test--range-items)) (color (etaf--expr-create @@ -271,19 +273,20 @@ :thunk (lambda () (cl-incf etaf-test-range-host-prop-calls) "red")))) - (lambda () - (cl-incf etaf-test-range-component-renders) - (etaf--view-node-create - :name 'column :props nil - :children - (append - (cl-loop for index below etaf-test-range-static-count - collect (etaf--view-call - 'text (append - (list :key (intern (format "static-%s" index))) - (and (zerop index) (list :color color))) - (list (format "S%s" index)))) - (list range)))))) + (list range color)) + :render + (let ((range (car (etaf-state))) (color (cadr (etaf-state)))) + (cl-incf etaf-test-range-component-renders) + (etaf-node + 'column nil + (append + (cl-loop for index below etaf-test-range-static-count + collect (etaf-node + 'text + (append (list :key (intern (format "static-%s" index))) + (and (zerop index) (list :color color))) + (list (format "S%s" index)))) + (list range))))) (etaf-define-component etaf-test-two-direct-ranges () "Render two disjoint direct material Ranges from one source." @@ -298,25 +301,24 @@ :thunk (lambda () (cl-incf etaf-test-range-right-evals) (etaf-test--prefixed-range-items "R"))))) - (lambda () - (etaf--view-node-create :name 'column :props nil - :children - (list (etaf--view-call 'text - (list :key 'static) - (list "S")) - left right))))) + (list left right)) + :render + (let ((ranges (etaf-state))) + (etaf-node 'column nil + (cons (etaf-node 'text (list :key 'static) (list "S")) + ranges)))) (etaf-define-component etaf-test-macro-range-token () "Expose one macro-compiled direct expr callsite." :view - (column (expr :value nil))) + (column (expr nil))) (etaf-define-component etaf-test-public-direct-range () "Exercise a public macro-compiled direct material-child expr." :view (column (text :key 'public-static "S") - (expr :value (etaf-test--range-items)))) + (expr (etaf-test--range-items)))) (etaf-define-component etaf-test-counted-direct-range (&key count) "Render COUNT static siblings before one stable direct Range callsite." @@ -324,17 +326,19 @@ (let ((range (etaf--expr-create :token 'etaf-test-counted-range-site :thunk #'etaf-test--range-items))) - (lambda () - (cl-incf etaf-test-range-component-renders) - (etaf--view-node-create - :name 'column :props nil - :children - (append - (cl-loop for index below count - collect (etaf--view-call - 'text (list :key (intern (format "counted-%s" index))) - (list (format "C%s" index)))) - (list range)))))) + range) + :render + (progn + (cl-incf etaf-test-range-component-renders) + (etaf-node + 'column nil + (append + (cl-loop for index below count + collect + (etaf-node + 'text (list :key (intern (format "counted-%s" index))) + (list (format "C%s" index)))) + (list (etaf-state)))))) (etaf-define-component etaf-test-string-sibling-range () "Render bare string siblings around one direct Range." @@ -342,9 +346,9 @@ (let ((range (etaf--expr-create :token 'etaf-test-string-sibling-range-site :thunk #'etaf-test--range-items))) - (lambda () - (etaf--view-node-create :name 'column :props nil - :children (list "prefix" range "suffix"))))) + range) + :render + (etaf-node 'column nil (list "prefix" (etaf-state) "suffix"))) (etaf-define-component etaf-test-unsupported-direct-range () "Start with a Host Range whose later unsupported output must fail." @@ -352,18 +356,19 @@ (let ((range (etaf--expr-create :token 'etaf-test-unsupported-range-site :thunk #'etaf-test--unsupported-range-value))) - (lambda () - (etaf--view-node-create - :name 'column :props nil - :children (list (etaf--view-call 'text (list :key 'static) (list "S")) - range))))) + range) + :render + (etaf-node + 'column nil + (list (etaf-node 'text (list :key 'static) (list "S")) + (etaf-state)))) (etaf-define-component etaf-test-public-string-range () "Render one public direct expr whose Range item is a bare string." :view (column (text :key 'static "S") - (expr :value (etaf-value etaf-test-string-range-source)))) + (expr (etaf-value etaf-test-string-range-source)))) (etaf-define-component etaf-test-nested-host-range () "Render one Range whose keyed item owns keyed nested Hosts." @@ -371,23 +376,39 @@ (let ((range (etaf--expr-create :token 'etaf-test-nested-range-site :thunk #'etaf-test--nested-range-value))) - (lambda () - (etaf--view-node-create - :name 'column :props nil - :children (list (etaf--view-call 'text (list :key 'static) (list "S")) - range))))) + range) + :render + (etaf-node + 'column nil + (list (etaf-node 'text (list :key 'static) (list "S")) + (etaf-state)))) + +(etaf-define-component etaf-test-nested-keyed-card (&key card) + "Render CARD with an independently keyed descendant list." + :view + (column + (text (expr (cadr card))) + (text :for (entry (etaf-value etaf-test-nested-inner-source)) + :key (car entry) + (expr (cdr entry))))) + +(etaf-define-component etaf-test-nested-keyed-ranges () + "Render a keyed outer list whose items contain keyed inner lists." + :view + (column + (etaf-test-nested-keyed-card + :for (card (etaf-value etaf-test-nested-outer-source)) + :key (car card) :card card))) (etaf-define-component etaf-test-inline-shared-hosts () "Render one shared source in two distinct text Hosts." :view (column (text :key 'left - (expr :value - (progn (cl-incf etaf-test-inline-shared-evals) + (expr (progn (cl-incf etaf-test-inline-shared-evals) (etaf-value etaf-test-inline-shared)))) (text :key 'right - (expr :value - (progn (cl-incf etaf-test-inline-shared-evals) + (expr (progn (cl-incf etaf-test-inline-shared-evals) (etaf-value etaf-test-inline-shared)))))) (etaf-define-component etaf-test-inline-dependency-branch () @@ -395,82 +416,77 @@ :setup (progn (etaf-on-updated (lambda () (cl-incf etaf-test-inline-branch-updated))) - (lambda () - (etaf-view - (text - (expr :value - (progn - (cl-incf etaf-test-inline-branch-evals) - (if (etaf-value etaf-test-inline-branch-mode) - (etaf-value etaf-test-inline-branch-right) - (etaf-value etaf-test-inline-branch-left)) - "same"))))))) + nil) + :view + (text + (expr (progn + (cl-incf etaf-test-inline-branch-evals) + (if (etaf-value etaf-test-inline-branch-mode) + (etaf-value etaf-test-inline-branch-right) + (etaf-value etaf-test-inline-branch-left)) + "same")))) (etaf-define-component etaf-test-slot-env-child () "Project the caller-owned default slot." :setup - (lambda () - (cl-incf etaf-test-slot-consumer-renders) - (etaf-view (column (slot))))) + (progn (cl-incf etaf-test-slot-consumer-renders) nil) + :view (column (slot))) (etaf-define-component etaf-test-slot-env-parent (&key label) "Author an inline slot expression from parent LABEL." - :setup - (lambda () + :setup nil + :render + (progn (cl-incf etaf-test-slot-parent-renders) - (etaf-view - (etaf-test-slot-env-child - (text (expr :value label)))))) + (etaf-node + 'etaf-test-slot-env-child nil + (list (etaf-node 'text nil (list label)))))) (etaf-define-component etaf-test-slot-env-consumer () "Project a forwarded named header slot." :setup - (lambda () - (cl-incf etaf-test-slot-consumer-renders) - (etaf-view (column (slot :name 'header))))) + (progn (cl-incf etaf-test-slot-consumer-renders) nil) + :view (column (slot :name 'header))) (etaf-define-component etaf-test-slot-env-forwarder () "Forward the caller-owned named header slot." :setup - (lambda () - (cl-incf etaf-test-slot-forwarder-renders) - (etaf--component-call-create - :spec etaf-test-slot-env-consumer--etaf-component-definition - :props nil - :slots (list (assq 'header etaf--current-component-slots))))) + (progn (cl-incf etaf-test-slot-forwarder-renders) nil) + :render + (etaf-node 'etaf-test-slot-env-consumer nil + nil + (list (cons 'header + (etaf-current-slot 'header))))) (etaf-define-component etaf-test-slot-env-named-parent (&key label) "Author a named slot expression from parent LABEL." - :setup - (lambda () + :setup nil + :render + (progn (cl-incf etaf-test-slot-parent-renders) - (etaf-view - (etaf-test-slot-env-forwarder - (slot :name 'header - (text (expr :value label))))))) + (etaf-node + 'etaf-test-slot-env-forwarder nil nil + (list (cons 'header + (list (etaf-node 'text nil (list label)))))))) (etaf-define-component etaf-test-slot-range-parent () "Author one reactive default slot Range." :setup (progn (etaf-on-updated (lambda () (cl-incf etaf-test-slot-author-updated))) - (lambda () - (cl-incf etaf-test-slot-parent-renders) - (etaf-view - (etaf-test-slot-env-child - (expr :value (etaf-test--slot-range-items))))))) + nil) + :view + (etaf-test-slot-env-child (expr (etaf-test--slot-range-items)))) (etaf-define-component etaf-test-slot-range-named-parent () "Author one reactive named slot through the Forwarder." :setup (progn (etaf-on-updated (lambda () (cl-incf etaf-test-slot-author-updated))) - (lambda () - (cl-incf etaf-test-slot-parent-renders) - (etaf-view - (etaf-test-slot-env-forwarder - (slot :name 'header - (expr :value (etaf-test--slot-range-items)))))))) + nil) + :view + (etaf-test-slot-env-forwarder + (slot :name 'header (expr (etaf-test--slot-range-items))))) (etaf-define-component etaf-test-slot-range-fallback () "Own one reactive fallback slot Range." @@ -478,11 +494,9 @@ :setup (progn (etaf-on-updated (lambda () (cl-incf etaf-test-slot-consumer-updated))) - (lambda () - (cl-incf etaf-test-slot-consumer-renders) - (etaf-view - (column - (slot (expr :value (etaf-test--slot-range-items)))))))) + nil) + :view + (column (slot (expr (etaf-test--slot-range-items))))) (etaf-define-component etaf-test-slot-range-two-sites () "Project the same default slot at two material sites." @@ -495,76 +509,74 @@ "Author one reactive slot consumed at two projection sites." :view (etaf-test-slot-range-two-sites - (expr :value (etaf-test--slot-range-items)))) + (expr (etaf-test--slot-range-items)))) (etaf-define-component etaf-test-slot-range-branch-parent (&key mode) "Retarget slot dependencies from MODE while preserving equal output." - :setup - (lambda () + :setup nil + :render + (progn (cl-incf etaf-test-slot-parent-renders) - (etaf-view - (etaf-test-slot-env-child - (expr :value - (progn - (if mode - (etaf-value etaf-test-slot-branch-right) - (etaf-value etaf-test-slot-branch-left)) - (list (etaf-view (text :key 'same "same"))))))))) + (etaf-node + 'etaf-test-slot-env-child nil + (list + (etaf--expr-create + :token 'etaf-test-slot-branch-site + :thunk + (lambda () + (if mode + (progn + (etaf-value etaf-test-slot-branch-right) + (list (etaf-node 'text (list :key 'same) (list "same")))) + (progn + (etaf-value etaf-test-slot-branch-left) + (list (etaf-node 'text (list :key 'same) (list "same"))))))))))) (etaf-define-component etaf-test-fragment-range-owner () "Own one material fragment Range." :setup - (lambda () - (cl-incf etaf-test-fragment-owner-renders) - (etaf-view - (column - (fragment - (expr :value (etaf-test--fragment-range-items))))))) + (progn (cl-incf etaf-test-fragment-owner-renders) nil) + :view (column (fragment (expr (etaf-test--fragment-range-items))))) (etaf-define-component etaf-test-transparent-owner () "Render a transparent fragment sequence." - :setup - (lambda () - (cl-incf etaf-test-transparent-renders) - (etaf-view - (fragment - (expr :value - (mapcar (lambda (entry) - (etaf--view-call 'text (list :key (car entry)) - (list (cdr entry)))) - (etaf-value etaf-test-transparent-source))))))) + :setup nil + :view + (fragment + (expr (progn + (cl-incf etaf-test-transparent-renders) + (mapcar (lambda (entry) + (etaf--view-call 'text (list :key (car entry)) + (list (cdr entry)))) + (etaf-value etaf-test-transparent-source)))))) (etaf-define-component etaf-test-transparent-parent () "Own one transparent child beside static material Hosts." :setup - (lambda () - (cl-incf etaf-test-transparent-parent-renders) - (etaf-view - (column - (text :key 'before "before") - (etaf-test-transparent-owner) - (text :key 'after "after"))))) + (progn (cl-incf etaf-test-transparent-parent-renders) nil) + :view + (column (text :key 'before "before") + (etaf-test-transparent-owner) + (text :key 'after "after"))) (etaf-define-component etaf-test-transparent-inner () "Render the inner transparent chain payload." - :setup - (lambda () - (cl-incf etaf-test-transparent-inner-renders) - (etaf-view - (fragment - (expr :value - (mapcar (lambda (entry) - (etaf--view-call 'text (list :key (car entry)) - (list (cdr entry)))) - (etaf-value etaf-test-transparent-source))))))) + :setup nil + :view + (fragment + (expr (progn + (cl-incf etaf-test-transparent-inner-renders) + (mapcar (lambda (entry) + (etaf--view-call 'text (list :key (car entry)) + (list (cdr entry)))) + (etaf-value etaf-test-transparent-source)))))) (etaf-define-component etaf-test-transparent-outer () "Forward one transparent Component without a visual adapter." :setup - (lambda () - (cl-incf etaf-test-transparent-outer-renders) - (etaf-view (fragment (etaf-test-transparent-inner))))) + (progn (cl-incf etaf-test-transparent-outer-renders) nil) + :view (fragment (etaf-test-transparent-inner))) (etaf-define-component etaf-test-transparent-chain-parent () "Place a transparent Component chain in one material parent." @@ -573,8 +585,7 @@ (etaf-define-component etaf-test-ancestor-artifact-child () "Render a child whose local update invalidates ancestor artifacts." :view - (text (expr :value - (if (etaf-value etaf-test-ancestor-child-source) + (text (expr (if (etaf-value etaf-test-ancestor-child-source) "detail" "child")))) (etaf-define-component etaf-test-ancestor-artifact-parent () @@ -586,60 +597,71 @@ (etaf-define-component etaf-test-generation-context-consumer () "Render one generation-owned Context dependency." :setup - (lambda () - (cl-incf etaf-test-context-consumer-renders) - (etaf-view (text :color (etaf-inject 'generation-label) "context")))) + (progn (cl-incf etaf-test-context-consumer-renders) nil) + :view + (text :color (etaf-value (etaf-inject 'generation-label)) "context")) (etaf-define-component etaf-test-generation-context-provider () "Provide a candidate Context value to one retained consumer." :setup - (lambda () + (progn + ;; Context values are provided during setup as stable reactive sources; + ;; consumers track the source value without requiring a render-time + ;; Context mutation. + (etaf-provide 'generation-label etaf-test-context-provider-source) + nil) + :render + (progn (cl-incf etaf-test-context-provider-renders) - (etaf-provide 'generation-label - (etaf-value etaf-test-context-provider-source)) - (etaf-view (etaf-test-generation-context-consumer)))) + (etaf-value etaf-test-context-provider-source) + (etaf-node 'etaf-test-generation-context-consumer nil nil))) (etaf-define-component etaf-test-generation-context-range-provider () "Provide Context directly to a retained child Range effect." :setup - (lambda () - (etaf-provide 'generation-label - (etaf-value etaf-test-context-provider-source)) - (etaf-view - (column - (expr :value - (progn - (cl-incf etaf-test-context-range-evals) - (list (etaf--view-call - 'text (list :key 'context-range) - (list (etaf-inject 'generation-label)))))))))) + (etaf-provide 'generation-label etaf-test-context-provider-source) + :render + (etaf-node + 'column nil + (list + (etaf--expr-create + :kind 'interpolation :token 'etaf-test-context-range-site + :thunk + (lambda () + (cl-incf etaf-test-context-range-evals) + (list (etaf-node 'text (list :key 'context-range) + (list (etaf-value + (etaf-inject 'generation-label)))))))))) (etaf-define-component etaf-test-generation-context-slot-consumer () "Project one material slot Range for Context ownership tests." :setup - (lambda () - (cl-incf etaf-test-slot-consumer-renders) - (etaf-view (column (slot))))) + (progn (cl-incf etaf-test-slot-consumer-renders) nil) + :view (column (slot))) (etaf-define-component etaf-test-generation-context-slot-provider () "Provide Context to an authored slot Range expression." :setup - (lambda () + (progn (cl-incf etaf-test-context-provider-renders) - (etaf-provide 'generation-label - (etaf-value etaf-test-context-provider-source)) - (etaf-view - (etaf-test-generation-context-slot-consumer - (expr :value - (progn - (cl-incf etaf-test-slot-range-evals) - (list (etaf--view-call - 'text (list :key 'context-slot) - (list (etaf-inject 'generation-label)))))))))) + (etaf-provide 'generation-label etaf-test-context-provider-source) + nil) + :render + (etaf-node + 'etaf-test-generation-context-slot-consumer nil + (list + (etaf--expr-create + :kind 'interpolation :token 'etaf-test-context-slot-site + :thunk + (lambda () + (cl-incf etaf-test-slot-range-evals) + (list (etaf-node 'text (list :key 'context-slot) + (list (etaf-value + (etaf-inject 'generation-label)))))))))) (etaf-define-component etaf-test-prop-env-child (&key value) "Render VALUE received from a parent Component." - :view (text (expr :value value))) + :view (text (expr value))) (etaf-define-component etaf-test-prop-env-parent (&key label) "Forward dynamic parent LABEL into a nested Component prop." @@ -650,15 +672,21 @@ :setup (progn (etaf-on-updated (lambda () (cl-incf etaf-test-inline-priority-updated))) - (lambda () - (cl-incf etaf-test-inline-priority-renders) - (etaf-view - (text - (expr :value - (progn - (cl-incf etaf-test-inline-priority-evals) - (format "%s/%s" label - (etaf-value etaf-test-inline-priority-source))))))))) + nil) + :render + (progn + (cl-incf etaf-test-inline-priority-renders) + (let ((input-label label)) + (etaf-node + 'text nil + (list + (etaf--expr-create + :kind 'interpolation :token 'etaf-test-inline-priority-site + :thunk + (lambda () + (cl-incf etaf-test-inline-priority-evals) + (format "%s/%s" input-label + (etaf-value etaf-test-inline-priority-source))))))))) (etaf-define-component etaf-test-inline-styled-owner () "Render a styled inline expression beside a side-effecting Host prop." @@ -666,8 +694,7 @@ (box :color (progn (cl-incf etaf-test-inline-host-prop-calls) "red") "P" (text :font-weight 'bold - (expr :value - (progn + (expr (progn (cl-incf etaf-test-inline-styled-evals) (etaf-value etaf-test-inline-styled-source)))))) @@ -683,14 +710,16 @@ (list (etaf--view-call 'text (list :key 'item :ref 'item) - (list (format "%s/%s" marker + (list (format "%s/%s" (etaf-current-prop 'marker) (etaf-value etaf-test-range-source))))))))) - (lambda () - (cl-incf etaf-test-range-component-renders) - (etaf--view-node-create - :name 'column :props nil - :children (list (etaf--view-call 'text (list :key 'static) (list "S")) - range))))) + range) + :render + (progn + (cl-incf etaf-test-range-component-renders) + (etaf-node + 'column nil + (list (etaf-node 'text (list :key 'static) (list "S")) + (etaf-state))))) (etaf-define-component etaf-test-next-turn () "Write TARGET after publishing a SOURCE update." @@ -702,11 +731,13 @@ (when (and etaf-test-next-turn-target (zerop (etaf-value target-cell))) (setf (etaf-value target-cell) 1)))) - (lambda () - (etaf-view - (text (expr :value - (format "%s/%s" (etaf-value source-cell) - (etaf-value target-cell)))))))) + (list source-cell target-cell)) + :view + (text + (expr + (format "%s/%s" + (etaf-value (car (etaf-state))) + (etaf-value (cadr (etaf-state))))))) (defun etaf-test--render-text (view) "Return plain rendered text for VIEW." @@ -725,18 +756,18 @@ (etaf-define-component etaf-test-badge (&key label) "Render LABEL as a small semantic test Component." :view - (text :font-weight 'bold (expr :value label))) + (text :font-weight 'bold (expr label))) (etaf-define-component etaf-list (&key label) "Render LABEL using the collision-safe `list-view' alias." :view - (text (expr :value label))) + (text (expr label))) (etaf-define-component etaf-test-slot-card (&key title) "Render a title with default and named slot projections." :view (column - (text (expr :value title)) + (text (expr title)) (slot :name 'header (text :color "#777777" "Default header")) (slot (text :color "#777777" "Default body")))) @@ -820,7 +851,8 @@ :setup (progn (etaf-theme-provide '(:color "theme-color" :bgcolor "theme-bg")) - (lambda () (etaf-view (text :color nil "Themed"))))) + nil) + :view (text "Themed")) (etaf-define-component etaf-test-themed-style-token () "Resolve a deferred Theme token from a static Component style." @@ -829,7 +861,8 @@ :setup (progn (etaf-theme-provide '(:color "token-color")) - (lambda () (etaf-view (text "Token"))))) + nil) + :view (text "Token")) (etaf-define-component etaf-test-stateful (&key label) "Render a retained counter for Runtime tests." @@ -840,10 +873,9 @@ (etaf-on-mounted (lambda () (cl-incf etaf-test-mounted-count))) (etaf-on-updated (lambda () (cl-incf etaf-test-updated-count))) (etaf-on-unmounted (lambda () (cl-incf etaf-test-unmounted-count))) - (lambda () - (etaf-view - (text - (expr :value (format "%s:%d" label (etaf-value cell)))))))) + cell) + :view + (text (expr (format "%s:%d" label (etaf-value (etaf-state)))))) (etaf-define-component etaf-test-provider () "Provide a reactive theme to descendants." @@ -851,23 +883,22 @@ (let ((theme (etaf-ref 'dark))) (setq etaf-test-theme-cell theme) (etaf-provide 'theme theme) - (lambda () - (etaf-view (column (slot)))))) + theme) + :view (column (slot))) (etaf-define-component etaf-test-consumer () "Render the nearest Context theme." :setup - (let ((theme (etaf-inject 'theme nil t))) - (lambda () - (etaf-view (text (expr :value (symbol-name (etaf-value theme)))))))) + (etaf-inject 'theme nil t) + :view (text (expr (symbol-name (etaf-value (etaf-state)))))) (etaf-define-component etaf-test-prop-stateful (&key label) "Render a retained label whose prop can change without rerunning setup." :setup (progn (cl-incf etaf-test-setup-count) - (lambda () - (etaf-view (text (expr :value label)))))) + nil) + :view (text (expr label))) (etaf-define-component etaf-test-lifecycle-failure (&key label) "Render LABEL and deliberately fail from an update lifecycle hook." @@ -877,20 +908,21 @@ (lambda () (when etaf-test-lifecycle-failure-p (error "test lifecycle failed")))) - (lambda () - (etaf-view (text (expr :value label)))))) + nil) + :view (text (expr label))) (etaf-define-component etaf-test-rollback (&key fail) "Render a candidate that can deliberately fail during reconciliation." :setup (let ((cell (etaf-ref 0))) (setq etaf-test-prop-cell cell) - (lambda () - (when fail - (signal 'etaf-runtime-error (list "test candidate failed"))) - (etaf-view - (text - (expr :value (format "stable:%d" (etaf-value cell)))))))) + cell) + :render + (progn + (when fail + (signal 'etaf-runtime-error (list "test candidate failed"))) + (etaf-node 'text nil + (list (format "stable:%d" (etaf-value (etaf-state))))))) (etaf-define-component etaf-test-late-branch () "Read a late reactive ref only after switching render branches." @@ -901,13 +933,13 @@ (setq etaf-test-branch-page-cell page etaf-test-branch-late-cell late etaf-test-branch-mode-cell late-branch) - (lambda () - (etaf-view - (text - (expr :value - (if (etaf-value late-branch) - (etaf-value late) - (etaf-value page)))))))) + (list page late late-branch)) + :view + (text + (expr + (if (etaf-value (nth 2 (etaf-state))) + (etaf-value (nth 1 (etaf-state))) + (etaf-value (nth 0 (etaf-state))))))) (etaf-define-component etaf-test-event-batch-stateful () "Render a callback with computed, watch, and effect dependents." @@ -930,19 +962,22 @@ (unless (equal next last-effect) (setq last-effect next) (setf (etaf-value effect-value) next))))) - (lambda () - (etaf-view - (column - (text :ref 'event-batch-trigger - :on-press (lambda () (setf (etaf-value source) 2)) - "Update") - (text - (expr :value - (format "source=%d computed=%d %s %s" - (etaf-value source) - (etaf-value computed) - (etaf-value watch-value) - (etaf-value effect-value))))))))) + (list :source source :computed computed + :watch watch-value :effect effect-value)) + :view + (column + (text :ref 'event-batch-trigger + :on-press + (let ((source (plist-get (etaf-state) :source))) + (lambda () (setf (etaf-value source) 2))) + "Update") + (text + (expr + (format "source=%d computed=%d %s %s" + (etaf-value (plist-get (etaf-state) :source)) + (etaf-value (plist-get (etaf-state) :computed)) + (etaf-value (plist-get (etaf-state) :watch)) + (etaf-value (plist-get (etaf-state) :effect))))))) (etaf-define-component etaf-test-event-batch-noop () "Render an event callback that performs no state write." @@ -954,45 +989,46 @@ (etaf-define-component etaf-test-event-batch-nested () "Render an outer callback that dispatches one nested public event." :setup - (let ((state (etaf-ref "idle"))) - (lambda () - (etaf-view - (column - (text :ref 'event-batch-nested-outer - :on-press - (lambda () - (etaf-dispatch-event - (etaf-current-runtime) - 'event-batch-nested-inner 'press)) - "Outer") - (text :ref 'event-batch-nested-inner - :on-press (lambda () (setf (etaf-value state) "nested")) - "Inner") - (text (expr :value (etaf-value state)))))))) + (etaf-ref "idle") + :view + (column + (text :ref 'event-batch-nested-outer + :on-press + (lambda () + (etaf-dispatch-event + (etaf-current-runtime) 'event-batch-nested-inner 'press)) + "Outer") + (text :ref 'event-batch-nested-inner + :on-press + (let ((state (etaf-state))) + (lambda () (setf (etaf-value state) "nested"))) + "Inner") + (text (expr (etaf-value (etaf-state)))))) (etaf-define-component etaf-test-event-batch-behavior () "Render a toggleable Behavior whose callback writes two refs." :setup (let ((left (etaf-ref nil)) (right (etaf-ref nil))) - (lambda () - (etaf-view - (column - (text :ref 'event-batch-behavior - :use - (list - (etaf-toggleable - :value left - :on-change - (lambda (value) - (setf (etaf-value left) value - (etaf-value right) value)))) - "Toggle") - (text - (expr :value - (format "left=%s right=%s" - (if (etaf-value left) "on" "off") - (if (etaf-value right) "on" "off"))))))))) + (list left right)) + :view + (column + (text :ref 'event-batch-behavior + :use + (let ((left (car (etaf-state))) (right (cadr (etaf-state)))) + (list + (etaf-toggleable + :value left + :on-change + (lambda (value) + (setf (etaf-value left) value + (etaf-value right) value))))) + "Toggle") + (text + (expr + (format "left=%s right=%s" + (if (etaf-value (car (etaf-state))) "on" "off") + (if (etaf-value (cadr (etaf-state))) "on" "off")))))) (etaf-define-component etaf-test-event-batch-theme () "Render a computed Theme changed by a public event callback." @@ -1004,16 +1040,16 @@ '(:color "dark") '(:color "light")))))) (etaf-theme-provide theme) - (lambda () - (etaf-view - (column - (text :ref 'event-batch-theme-toggle - :on-press - (lambda () - (setf (etaf-value dark) (not (etaf-value dark)))) - "Theme") - (text (expr :value - (format "theme=%s" (etaf-theme-value :color))))))))) + dark) + :view + (column + (text :ref 'event-batch-theme-toggle + :on-press + (let ((dark (etaf-state))) + (lambda () + (setf (etaf-value dark) (not (etaf-value dark))))) + "Theme") + (text (expr (format "theme=%s" (etaf-theme-value :color)))))) (defvar etaf-test-theme-property-render-count 0) (defvar etaf-test-theme-property-cell nil) @@ -1056,16 +1092,20 @@ '(:color "#111111" :bgcolor "#FFFFFF")))))) (setq etaf-test-theme-property-cell dark) (etaf-theme-provide theme) - (lambda () - (cl-incf etaf-test-theme-property-render-count) - (etaf-view - (text :ref 'theme-property-toggle + dark) + :render + (progn + (cl-incf etaf-test-theme-property-render-count) + (let ((dark (etaf-state))) + (etaf-node + 'text + (list :ref 'theme-property-toggle :color (etaf-theme-token :color) :bgcolor (etaf-theme-token :bgcolor) :on-press (lambda () - (setf (etaf-value dark) (not (etaf-value dark)))) - "Theme property"))))) + (setf (etaf-value dark) (not (etaf-value dark))))) + (list "Theme property"))))) (etaf-define-component etaf-test-theme-atomic-child (&key label on-press) "Render Theme paint below a Component whose input also changes." @@ -1074,7 +1114,7 @@ :color (etaf-theme-token :color) :bgcolor (etaf-theme-token :bgcolor) (text :ref 'theme-atomic-toggle :on-press on-press - (expr :value label)))) + (expr label)))) (etaf-define-component etaf-test-theme-atomic-owner () "Change Component content and descendant Theme properties in one turn." @@ -1089,76 +1129,66 @@ (toggle (lambda () (setf (etaf-value dark) (not (etaf-value dark)))))) (etaf-theme-provide theme) - (lambda () - (etaf--view-call - 'column (list :ref 'theme-atomic-root - :bgcolor (etaf-theme-token :bgcolor)) - (list - (etaf--view-call - 'etaf-test-theme-atomic-child - (list :label (if (etaf-value dark) "Dark" "Light") - :on-press toggle) - nil)))))) + (list dark toggle)) + :view + (column :ref 'theme-atomic-root + :bgcolor (etaf-theme-token :bgcolor) + (etaf-test-theme-atomic-child + :label (if (etaf-value (car (etaf-state))) "Dark" "Light") + :on-press (cadr (etaf-state))))) (etaf-define-component etaf-test-detached-theme-row (&key row-ref label) "Render one keyed Theme-bound row used by detached-subtree tests." :setup - (lambda () - (cl-incf etaf-test-detached-row-renders) - (etaf--view-call - 'row - (list :ref (etaf-current-prop :row-ref) - :color (etaf-theme-token :color)) - (list (etaf--view-call - 'text nil (list (etaf-current-prop :label))))))) + (progn (cl-incf etaf-test-detached-row-renders) nil) + :view + (row :ref row-ref :color (etaf-theme-token :color) + (text (expr label)))) (etaf-define-component etaf-test-detached-theme-list () "Render keyed Components below stable nested Host containers." :setup (progn (etaf-theme-provide etaf-test-detached-theme-source) - (lambda () - (etaf--view-call - 'column (list :key 'shell) - (list - (etaf--view-call - 'column (list :key 'body) - (mapcar - (lambda (entry) - (etaf--view-call - 'etaf-test-detached-theme-row - (list :key (car entry) :row-ref (car entry) :label (cdr entry)) - nil)) - (etaf-value etaf-test-detached-list-source)))))))) + nil) + :view + (column :key 'shell + (column :key 'body + (etaf-test-detached-theme-row + :for (entry (etaf-value etaf-test-detached-list-source)) + :key (car entry) :row-ref (car entry) :label (cdr entry))))) (etaf-define-component etaf-test-event-batch-resource (&key resource fail) "Render synchronous Resource success and error state transitions." :setup (let ((instance-resource resource) (instance-fail fail)) - (lambda () - (etaf-view - (column - (text :ref 'event-batch-resource-success - :on-press - (lambda () - (setf (etaf-value instance-fail) nil) - (etaf-resource-load instance-resource)) - "Load success") - (text :ref 'event-batch-resource-error - :on-press - (lambda () - (setf (etaf-value instance-fail) t) - (etaf-resource-load instance-resource)) - "Load error") - (text - (expr :value - (format "status=%s value=%s error=%s" - (etaf-resource-status instance-resource) - (or (etaf-resource-value instance-resource) "none") - (if (etaf-resource-error instance-resource) - "yes" - "no"))))))))) + (list instance-resource instance-fail)) + :view + (column + (text :ref 'event-batch-resource-success + :on-press + (let ((resource (car (etaf-state))) + (fail (cadr (etaf-state)))) + (lambda () + (setf (etaf-value fail) nil) + (etaf-resource-load resource))) + "Load success") + (text :ref 'event-batch-resource-error + :on-press + (let ((resource (car (etaf-state))) + (fail (cadr (etaf-state)))) + (lambda () + (setf (etaf-value fail) t) + (etaf-resource-load resource))) + "Load error") + (text + (expr + (let ((resource (car (etaf-state)))) + (format "status=%s value=%s error=%s" + (etaf-resource-status resource) + (or (etaf-resource-value resource) "none") + (if (etaf-resource-error resource) "yes" "no"))))))) (etaf-define-behavior etaf-test-cleanup-behavior (&rest attributes) "Construct a Behavior whose disposal is visible to tests." @@ -1201,7 +1231,7 @@ "Evaluate an attribute expression without an extra evaluation wrapper." (let ((face 'bold) (label "Ready")) - (let ((view (etaf-view (text :font-weight face (expr :value label))))) + (let ((view (etaf-view (text :font-weight face (expr label))))) (should (equal "Ready" (etaf-test--render-text view)))))) (ert-deftest etaf-host-metadata-uses-the-frozen-runtime-grammar () @@ -1239,7 +1269,7 @@ (equal "yes" (etaf-test--render-text (etaf-view - (text (expr :value (if checked "yes" "no"))))))))) + (text (expr (if checked "yes" "no"))))))))) (ert-deftest etaf-view-expr-can-return-a-view () "Allow an expression to return a dynamically constructed View." @@ -1249,19 +1279,17 @@ (etaf-test--render-text (etaf-view (column - (expr - :value - (when open + (expr (when open (etaf-view (text "Details"))))))))))) (ert-deftest etaf-text-expr-requires-one-string () "Reject structural and sequence values at the Text interpolation boundary." (dolist (view (list - (etaf-view (text (expr :value (list "A" "B")))) + (etaf-view (text (expr (list "A" "B")))) (etaf-view (text - (expr :value (etaf-view (text :face 'bold "B"))))))) + (expr (etaf-view (text :face 'bold "B"))))))) (should-error (etaf-test--render-text view) :type 'etaf-renderer-error))) @@ -1363,7 +1391,7 @@ buffer-name (etaf-view (row - (text (expr :value (etaf-value source))) + (text (expr (etaf-value source))) (text "B")))) (should (string-match-p "AB" (etaf-test--buffer-text buffer-name))) (setf (etaf-value source) "C") @@ -1388,12 +1416,10 @@ (should (string-match-p "A" (substring-no-properties (ebox-render node)))) (should (string-match-p "B" (substring-no-properties (ebox-render node)))))) -(ert-deftest etaf-view-prefixed-host-alias-lowers-to-canonical-host () - "Resolve an explicit `etaf-' Host spelling to its core Host name." - (should - (equal "Hello" - (etaf-test--render-text - (etaf-view (etaf-text "Hello")))))) +(ert-deftest etaf-view-prefixed-host-is-not-an-implicit-alias () + "Keep the core Host registry exact instead of deriving prefix aliases." + (should-error (etaf-view (etaf-text "Hello")) + :type 'etaf-component-call-error)) (ert-deftest etaf-component-view-renders-props () "Render a stateless Component from its declared props." @@ -1401,19 +1427,19 @@ (should (etaf--component-call-p view)) (should (equal "Ready" (etaf-test--render-text view))))) -(ert-deftest etaf-component-prefixed-name-has-short-alias () - "Resolve an `etaf-' Component through its public View alias." - (should - (equal "Ready" - (etaf-test--render-text - (etaf-view (test-badge :label "Ready")))))) +(ert-deftest etaf-component-prefixed-name-is-not-an-implicit-alias () + "Keep an `etaf-' Component name exact in the public registry." + (should-error (etaf-view (test-badge :label "Ready")) + :type 'etaf-component-call-error)) -(ert-deftest etaf-component-alias-avoids-elisp-collision () - "Use a semantic alias when the unprefixed name is an Elisp function." +(ert-deftest etaf-component-registry-does-not-generate-elisp-aliases () + "Use the exact Component name even when an Elisp function collides." (should (equal "Items" (etaf-test--render-text - (etaf-view (list-view :label "Items")))))) + (etaf-view (etaf-list :label "Items"))))) + (should-error (etaf-view (list-view :label "Items")) + :type 'etaf-component-call-error)) (ert-deftest etaf-component-rejects-unknown-props () "Reject undeclared Component props at the Component boundary." @@ -1426,7 +1452,8 @@ (should (macroexpand '(etaf-define-component setup-component (&key value) - :setup (lambda () (etaf-view (text (expr :value value))))))) + :setup value + :render (etaf-node 'text nil (list value))))) (should (macroexpand '(etaf-define-component styled-component () @@ -1435,8 +1462,8 @@ (should-error (macroexpand '(etaf-define-component ambiguous-component (&key value) - :setup value - :view (text "x"))) + :view (text "x") + :render (etaf-node 'text nil (list value)))) :type 'etaf-component-definition-error) (should-error (macroexpand @@ -2660,6 +2687,98 @@ Event composition is a Runtime contract, not a UI-library helper contract." (should (< (etaf--generation-metrics-node-copies batch-metrics) (etaf--generation-metrics-node-copies sequential-metrics))))) +(ert-deftest etaf-runtime-generation-batches-effect-source-index-updates () + "Build equivalent Effect/Source indexes with fewer persistent node copies." + (let* ((buffer-name " *etaf-generation-effect-batch-test*") + (cells (cl-loop repeat 64 collect (etaf-ref 0))) + (etaf-test-retained-render-counts (make-hash-table :test #'eql)) + (original-put-many (symbol-function 'etaf--pvec-put-many)) + batches runtime) + (unwind-protect + (progn + (cl-letf + (((symbol-function 'etaf--pvec-put-many) + (lambda (root entries &optional metrics) + (let ((sequential-metrics + (etaf--generation-metrics-create)) + (sequential root) + (before (and metrics + (etaf--generation-metrics-node-copies + metrics)))) + (dolist (entry entries) + (setq sequential + (etaf--pvec-put sequential (car entry) (cdr entry) + sequential-metrics))) + (let* ((result + (funcall original-put-many root entries metrics)) + (values (mapcar #'cdr entries)) + (kind + (cond + ((cl-some #'etaf--generation-effect-p values) + 'effect-map) + ((cl-some + (lambda (value) + (and (proper-list-p value) + (cl-some + (lambda (item) + (or (etaf-ref-p item) + (etaf-computed-p item))) + value))) + values) + 'effect-sources) + ((cl-some + (lambda (value) + (and value (proper-list-p value) + (cl-every #'integerp value))) + values) + 'source-effects)))) + (should (equal result sequential)) + (when kind + (push + (list kind + (- (etaf--generation-metrics-node-copies metrics) + before) + (etaf--generation-metrics-node-copies + sequential-metrics)) + batches)) + result))))) + (etaf-mount + buffer-name + (lambda () + (etaf--view-call + 'column nil + (cl-loop for cell in cells for index from 0 + collect + (etaf--view-call + 'etaf-test-retained-leaf + (list :key index :label index :cell cell) nil)))))) + (setq runtime (etaf-runtime-for-buffer buffer-name)) + (let* ((generation (etaf-runtime-current-generation runtime)) + (effect-map (etaf-generation-effect-map generation)) + (source-effects (etaf-generation-source-effects generation)) + (effect-sources (etaf-generation-effect-sources generation))) + (dolist (source cells) + (let ((effect-ids + (etaf--pvec-get source-effects + (etaf-reactive-source-id source)))) + (should effect-ids) + (should (equal effect-ids + (sort (copy-sequence effect-ids) #'<))) + (dolist (effect-id effect-ids) + (let ((effect (etaf--pvec-get effect-map effect-id))) + (should (memq source + (etaf--generation-effect-deps effect))) + (should (equal + (etaf--generation-effect-deps effect) + (etaf--pvec-get effect-sources effect-id)))))))) + (dolist (kind '(effect-map effect-sources source-effects)) + (let ((batch (assq kind batches))) + (should batch) + (should (= 1 (cl-count kind batches :key #'car))) + (should (< (nth 1 batch) (nth 2 batch)))))) + (when runtime (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer))))) + (ert-deftest etaf-runtime-component-overlay-does-zero-unrelated-work () "Point-update one of 500 retained Components without Root or sibling work." (let* ((buffer-name " *etaf-persistent-generation-test*") @@ -3310,7 +3429,7 @@ Event composition is a Runtime contract, not a UI-library helper contract." (should (integerp range-id)) (should (etaf--semantic-range-p range)) (should (integerp (etaf--semantic-range-parent-id range))) - (should (= 1 (length (etaf--semantic-range-item-host-ids range)))) + (should (= 1 (length (etaf--semantic-range-item-root-ids range)))) (should (equal '(range) (mapcar @@ -3759,7 +3878,7 @@ Event composition is a Runtime contract, not a UI-library helper contract." (etaf-generation-semantic-nodes generation) (etaf--generation-effect-semantic-id effect)))) (should (eq 'range (etaf--generation-effect-kind effect))) - (should (= 1 (length (etaf--semantic-range-item-host-ids range)))) + (should (= 1 (length (etaf--semantic-range-item-root-ids range)))) (should (string-match-p "hello" (etaf-test--buffer-text buffer-name))))) (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) @@ -3823,7 +3942,7 @@ Event composition is a Runtime contract, not a UI-library helper contract." (removed-ids (etaf--runtime-generation-descendant-ids old-generation - (etaf--semantic-range-item-host-ids old-range)))) + (etaf--semantic-range-item-root-ids old-range)))) (setf (etaf-value etaf-test-nested-range-present) nil) (let ((new-generation (etaf-runtime-current-generation runtime))) @@ -3843,6 +3962,198 @@ Event composition is a Runtime contract, not a UI-library helper contract." (etaf-unmount runtime)) (when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer))))) +(ert-deftest etaf-runtime-nested-keyed-range-publishes-deepest-change () + "Retain nested Range anchors and publish only the independently changed one." + (let ((buffer-name " *etaf-nested-keyed-range-test*") + (etaf-test-nested-outer-source (etaf-ref '((card-a "A" 0)))) + (etaf-test-nested-inner-source (etaf-ref '((row-a . "one"))))) + (unwind-protect + (progn + (etaf-mount buffer-name (etaf-view (etaf-test-nested-keyed-ranges))) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (generation (etaf-runtime-current-generation runtime)) + (outer-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-outer-source))) + (inner-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-inner-source))) + (outer + (etaf--generation-effect-semantic generation outer-effect-id)) + (inner + (etaf--generation-effect-semantic generation inner-effect-id)) + (outer-id (etaf--semantic-range-semantic-id outer)) + (inner-id (etaf--semantic-range-semantic-id inner)) + (outer-ref (etaf--semantic-range-range-ref outer)) + (inner-ref (etaf--semantic-range-range-ref inner)) + (replace-range (symbol-function + 'ebox-candidate-replace-range-ref)) + replacements) + (should (etaf--semantic-range-p outer)) + (should (etaf--semantic-range-p inner)) + (should-not (= outer-id inner-id)) + (should (member outer-id + (etaf--runtime-generation-descendant-ids + generation (list outer-id)))) + (should (member inner-id + (etaf--runtime-generation-descendant-ids + generation (list outer-id)))) + (cl-letf (((symbol-function 'ebox-candidate-replace-range-ref) + (lambda (candidate range-ref input + &optional reuse-map retain-item-identities-p) + (push range-ref replacements) + (funcall replace-range candidate range-ref + input reuse-map + retain-item-identities-p)))) + (setf (etaf-value etaf-test-nested-inner-source) + '((row-a . "two")))) + (should (equal (list inner-ref) (nreverse replacements))) + (setq generation (etaf-runtime-current-generation runtime)) + (let ((new-outer (etaf--pvec-get + (etaf-generation-semantic-nodes generation) + outer-id)) + (new-inner (etaf--pvec-get + (etaf-generation-semantic-nodes generation) + inner-id))) + (should (equal outer-ref + (etaf--semantic-range-range-ref new-outer))) + (should (equal inner-ref + (etaf--semantic-range-range-ref new-inner)))))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer))))) + +(ert-deftest etaf-runtime-nested-keyed-range-ancestor-absorbs-descendant () + "Publish one outer Range replacement when outer and inner inputs both change." + (let ((buffer-name " *etaf-nested-keyed-range-absorb-test*") + (etaf-test-nested-outer-source (etaf-ref '((card-a "A" 0)))) + (etaf-test-nested-inner-source (etaf-ref '((row-a . "one"))))) + (unwind-protect + (progn + (etaf-mount buffer-name (etaf-view (etaf-test-nested-keyed-ranges))) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (generation (etaf-runtime-current-generation runtime)) + (outer-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-outer-source))) + (inner-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-inner-source))) + (outer + (etaf--generation-effect-semantic generation outer-effect-id)) + (inner + (etaf--generation-effect-semantic generation inner-effect-id)) + (outer-ref (etaf--semantic-range-range-ref outer)) + (inner-id (etaf--semantic-range-semantic-id inner)) + (inner-parent-id (etaf--semantic-range-parent-id inner)) + (inner-ref (etaf--semantic-range-range-ref inner)) + (replace-range (symbol-function + 'ebox-candidate-replace-range-ref)) + (sort-effects (symbol-function + 'etaf--runtime-sort-dirty-effects)) + replacements) + (cl-letf (((symbol-function 'ebox-candidate-replace-range-ref) + (lambda (candidate range-ref input + &optional reuse-map retain-item-identities-p) + (push range-ref replacements) + (funcall replace-range candidate range-ref + input reuse-map + retain-item-identities-p))) + ;; Prove normalization is independent of the incidental + ;; creation order of ancestor and descendant effects. + ((symbol-function 'etaf--runtime-sort-dirty-effects) + (lambda (base effect-ids) + (nreverse (funcall sort-effects base effect-ids))))) + (etaf-runtime-event-begin runtime) + (setf (etaf-value etaf-test-nested-inner-source) + '((row-a . "two"))) + (setf (etaf-value etaf-test-nested-outer-source) + '((card-a "A2" 0))) + (etaf-runtime-event-end runtime)) + (should (equal (list outer-ref) (nreverse replacements))) + (setq generation (etaf-runtime-current-generation runtime)) + (let ((retained-inner + (etaf--pvec-get + (etaf-generation-semantic-nodes generation) inner-id))) + (should (etaf--semantic-range-p retained-inner)) + (should (= inner-parent-id + (etaf--semantic-range-parent-id retained-inner))) + (should (equal inner-ref + (etaf--semantic-range-range-ref retained-inner)))) + (should (equal "A2 two" (etaf-test--buffer-text buffer-name))))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer))))) + +(ert-deftest etaf-runtime-nested-keyed-range-drops-shallow-stable-ancestor () + "Drop an outer artifact staged solely because its descendant changed." + (let ((buffer-name " *etaf-nested-keyed-range-shallow-test*") + (etaf-test-nested-outer-source (etaf-ref '((card-a "A" 0)))) + (etaf-test-nested-inner-source (etaf-ref '((row-a . "one"))))) + (unwind-protect + (progn + (etaf-mount buffer-name (etaf-view (etaf-test-nested-keyed-ranges))) + (let* ((runtime (etaf-runtime-for-buffer buffer-name)) + (generation (etaf-runtime-current-generation runtime)) + (outer-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-outer-source))) + (inner-effect-id + (car (etaf--generation-source-effects + generation etaf-test-nested-inner-source))) + (outer + (etaf--generation-effect-semantic generation outer-effect-id)) + (inner + (etaf--generation-effect-semantic generation inner-effect-id)) + (outer-ref (etaf--semantic-range-range-ref outer)) + (inner-ref (etaf--semantic-range-range-ref inner)) + (replace-range (symbol-function + 'ebox-candidate-replace-range-ref)) + (normalize (symbol-function + 'etaf--runtime-normalize-range-changes)) + staged-refs replacements) + (cl-letf + (((symbol-function 'ebox-candidate-replace-range-ref) + (lambda (candidate range-ref input + &optional reuse-map retain-item-identities-p) + (push range-ref replacements) + (funcall replace-range candidate range-ref + input reuse-map + retain-item-identities-p))) + ((symbol-function 'etaf--runtime-normalize-range-changes) + (lambda (active-runtime base changes) + (let* ((inner-change + (cl-find inner-ref changes + :key (lambda (change) + (etaf--semantic-backend-range-ref + (car change))) + :test #'equal)) + ;; Model the real staging boundary: rebuilding an + ;; ancestor artifact observes the changed descendant + ;; input even though the ancestor semantic payload + ;; and retained identity are unchanged. + (ancestor-change + (list outer outer + (etaf--runtime-committed-range-input + active-runtime outer) + (nth 3 inner-change) nil)) + (staged (cons ancestor-change changes))) + (setq staged-refs + (mapcar + (lambda (change) + (etaf--semantic-backend-range-ref (car change))) + staged)) + (funcall normalize active-runtime base staged))))) + (setf (etaf-value etaf-test-nested-inner-source) + '((row-a . "two")))) + (should (member outer-ref staged-refs)) + (should (member inner-ref staged-refs)) + (should (equal (list inner-ref) (nreverse replacements))) + (should (equal "A two" (etaf-test--buffer-text buffer-name))))) + (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) + (etaf-unmount runtime)) + (when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer))))) + (ert-deftest etaf-runtime-shared-inline-source-updates-distinct-text-hosts () "Publish two distinct Text hosts that read one shared source in one commit." @@ -4416,12 +4727,16 @@ Event composition is a Runtime contract, not a UI-library helper contract." (should (etaf--semantic-component-p parent)) (should-not (etaf--semantic-component-artifact-key parent)) (setf (etaf-value etaf-test-ancestor-parent-source) "dark") - (should (equal - (plist-get - (etaf-runtime-host-props-for - runtime '(etaf-host (root :view))) - :bgcolor) - "dark")))) + (let* ((host + (etaf--pvec-get + (etaf-generation-semantic-nodes generation) + (car (etaf--semantic-component-child-ids parent)))) + (host-ref (etaf--semantic-host-host-ref host))) + (should (equal + (plist-get + (etaf-runtime-host-props-for runtime host-ref) + :bgcolor) + "dark"))))) (when-let* ((runtime (etaf-runtime-for-buffer buffer-name))) (etaf-unmount runtime)) (when-let* ((buffer (get-buffer buffer-name))) @@ -4646,7 +4961,9 @@ Event composition is a Runtime contract, not a UI-library helper contract." etaf-test-slot-consumer-renders 0 etaf-test-context-provider-renders 0) (setf (etaf-value etaf-test-context-provider-source) "B") - (should (= 1 etaf-test-context-provider-renders)) + ;; The provider publishes a stable reactive Context ref during + ;; setup; this direct slot Range update must not rerender it. + (should (zerop etaf-test-context-provider-renders)) (should (= 1 etaf-test-slot-range-evals)) (should (zerop etaf-test-slot-consumer-renders)) (should (string-match-p "B" (etaf-test--buffer-text buffer-name))) diff --git a/tests/fixtures/etaf-m0a-condition-consumers.sexp b/tests/fixtures/etaf-m0a-condition-consumers.sexp new file mode 100644 index 0000000..a27dbc1 --- /dev/null +++ b/tests/fixtures/etaf-m0a-condition-consumers.sexp @@ -0,0 +1,20 @@ +((:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment) + (:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment) + (:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment) + (:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment) + (:file "etaf-observer.el" :form condition-case :conditions (error) :owner etaf-observer :policy generic-containment) + (:file "etaf-observer.el" :form condition-case :conditions (quit) :owner etaf-observer :policy generic-containment) + (:file "etaf-performance.el" :form condition-case :conditions (etaf-runtime-error) :owner etaf-performance :policy specific-compatibility) + (:file "etaf-performance.el" :form condition-case :conditions (error) :owner etaf-performance :policy generic-containment) + (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) + (:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment) + (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) + (:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (quit) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment) + (:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment))