geekinney/etaf
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: close M0 core interaction contracts

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-31 15:18:26 +08:00
parent 8d685b75e3
commit 525e6b38b7
15 changed files with 2423 additions and 946 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -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

24
etaf-actions.el
View File

@ -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.

33
etaf-compiler.el
View File

@ -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

79
etaf-data.el
View File

@ -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)

25
etaf-renderer.el
View File

@ -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

745
etaf-runtime.el
View File

@ -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))

9
etaf-view.el
View File

@ -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)))

138
examples/etaf-counter-example.el
View File

@ -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 ()

213
examples/etaf-data-example.el
View File

@ -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 ()

138
examples/etaf-resource-example.el
View File

@ -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 ()

315
scripts/etaf-m0a-inventory.el Normal file
View File

@ -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

284
tests/etaf-interaction-contract-tests.el Normal file
View File

@ -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

201
tests/etaf-m0a-current-characterization-tests.el Normal file
View File

@ -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

1143
tests/etaf-tests.el
View File

File diff suppressed because it is too large Load Diff

20
tests/fixtures/etaf-m0a-condition-consumers.sexp vendored Normal file
View File

@ -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))