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

feat: establish unified Component authoring core

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-28 23:21:27 +08:00
parent 8e305b172e
commit 7e8700113f
12 changed files with 1615 additions and 345 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
etaf-actions.el
View File

@ -33,6 +33,7 @@
(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))))
@ -63,6 +64,7 @@ through `etaf-dispatch'."
An explicit Runtime may be supplied as the first argument: `(etaf-dispatch
RUNTIME ACTION ...)'. Action functions receive Runtime first."
(etaf--assert-not-rendering 'dispatch-action)
(let* ((explicit-runtime (etaf-runtime-p action))
(runtime (if explicit-runtime
action
@ -94,6 +96,7 @@ RUNTIME ACTION ...)'. Action functions receive Runtime first."
;;;###autoload
(defun etaf-action-undefine (name)
"Remove named Action NAME and return NAME."
(etaf--assert-not-rendering 'undefine-action)
(remhash name etaf--action-registry)
name)

252
etaf-compiler.el
View File

@ -15,12 +15,11 @@
(require 'cl-lib)
(require 'etaf-view)
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/1")
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/2")
(defvar etaf-compiler--static-cache (make-hash-table :test #'equal))
(defvar etaf-compiler--registry-epoch 0)
(defvar etaf-compiler--instantiate-count 0)
(defvar etaf-compiler--fallback-count 0)
(defvar etaf-compiler--last-blueprint nil)
(defun etaf-compiler-note-registry-change ()
@ -37,7 +36,6 @@
"Return a read-only snapshot of compiler runtime statistics."
(list :abi etaf-compiler-blueprint-abi
:instantiations etaf-compiler--instantiate-count
:fallbacks etaf-compiler--fallback-count
:static-cache-entries (hash-table-count etaf-compiler--static-cache)
:last-blueprint
(and etaf-compiler--last-blueprint
@ -68,29 +66,93 @@
(cons (list :kind 'hole :index index)
(append programs (list `(lambda () ,form)))))))
(defun etaf-compiler--compile-block (form path programs)
(defun etaf-compiler--form-directives (form)
"Return validated compiler directives from raw View FORM, or nil."
(when (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot))))
(let ((props
(car (etaf--parse-attributes-and-children (cdr form)))))
(etaf--validate-directive-set
(etaf--view-directive-properties props)))))
(defun etaf-compiler--compile-program-block (kind code path programs)
"Compile structural KIND from executable CODE at PATH using PROGRAMS."
(let ((index (length programs)))
(list (list :kind kind :path path :hole index :static-p nil)
(append programs (list `(lambda () ,code))))))
(defun etaf-compiler--compile-children
(children path programs slot-mode)
"Compile sibling CHILDREN below PATH with directive grouping."
(let ((child-index 0)
blocks)
(while children
(let* ((form (car children))
(directives (etaf-compiler--form-directives form))
compiled
consumed)
(cond
((and directives (plist-member directives :if))
(pcase-let ((`(,code . ,remaining)
(etaf--compile-branch-children
form (cdr children) slot-mode)))
(setq compiled
(etaf-compiler--compile-program-block
'branch code (append path (list child-index)) programs)
consumed (- (length children) (length remaining))
children remaining)))
((and directives (plist-member directives :for))
(setq compiled
(etaf-compiler--compile-program-block
'keyed-list
(etaf--compile-for-child form slot-mode)
(append path (list child-index)) programs)
consumed 1
children (cdr children)))
((and directives
(or (plist-member directives :else-if)
(plist-member directives :else)))
(etaf--syntax-error "Orphan branch arm: %S" form))
(t
(setq compiled
(etaf-compiler--compile-block
form (append path (list child-index)) programs slot-mode)
consumed 1
children (cdr children))))
(setq programs (cadr compiled)
blocks (append blocks (list (car compiled))))
(cl-incf child-index consumed)))
(list blocks programs)))
(defun etaf-compiler--compile-block (form path programs slot-mode)
"Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
(cond
((or (null form) (stringp form))
(list (list :kind 'literal :value form :path path :static-p t) programs))
((not (and (consp form) (symbolp (car form)))) nil)
((not (and (consp form) (symbolp (car form))))
(etaf--syntax-error "View form must start with a tag symbol: %S" form))
((eq (car form) 'expr)
(let ((index (length programs)))
(list (list :kind 'expr :path path :hole index :static-p nil)
(append programs
(list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
((eq (car form) 'slot) nil)
((etaf--ordinary-expression-head-p (car form)) nil)
((eq (car form) 'slot)
(etaf-compiler--compile-program-block
'slot (etaf--compile-slot-form (cdr form) slot-mode) path programs))
((and (null (gethash (car form) etaf--view-registry))
(etaf--ordinary-expression-head-p (car form)))
(etaf--syntax-error
"Elisp expression %S must be inside (expr FORM)" (car form)))
(t
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
(props (car parts))
(children (cdr parts))
(host-view-p
(eq (gethash (car form) etaf--view-registry) etaf--host-marker))
(child-slot-mode (if host-view-p slot-mode :input))
(compiled-props nil)
(compiled-children nil)
(all-static t)
(tail props)
(child-index 0)
result)
(tail props))
(while tail
(let* ((key (pop tail))
(value (pop tail))
@ -101,22 +163,15 @@
(setq all-static nil))
(setq compiled-props
(append compiled-props (list key descriptor)))))
(while (and children (not (eq result 'unsupported)))
(let ((compiled
(etaf-compiler--compile-block
(pop children) (append path (list child-index)) programs)))
(if (not compiled)
(setq result 'unsupported)
(let ((block (car compiled)))
(setq programs (cadr compiled)
compiled-children (append compiled-children (list block)))
(unless (plist-get block :static-p) (setq all-static nil)))))
(cl-incf child-index))
(unless (eq result 'unsupported)
(pcase-let* ((`(,compiled-children ,next-programs)
(etaf-compiler--compile-children
children path programs child-slot-mode)))
(dolist (block compiled-children)
(unless (plist-get block :static-p) (setq all-static nil)))
(list (list :kind 'node :name (car form) :path path
:props compiled-props :children compiled-children
:static-p all-static)
programs))))))
next-programs))))))
(defun etaf-compiler--block-counts (block)
"Return `(STATIC . DYNAMIC)' node counts below BLOCK."
@ -131,15 +186,15 @@
(cl-incf dynamic child-dynamic)))
(cons static dynamic))))
(defun etaf-compiler--beneficial-blueprint-p (blueprint)
"Return non-nil when BLUEPRINT can reuse at least one static node."
(> (or (plist-get blueprint :static-nodes) 0) 0))
(defun etaf-compiler--compile (form)
(defun etaf-compiler--compile (form &optional slot-mode)
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
(when-let* ((compiled (etaf-compiler--compile-block form '(0) nil)))
(let* ((root (car compiled))
(programs (cadr compiled))
(pcase-let* ((`(,roots ,programs)
(etaf-compiler--compile-children
(list form) nil nil (or slot-mode :projection)))
(root (car roots)))
(unless (and root (null (cdr roots)))
(etaf--syntax-error "A View blueprint requires exactly one root"))
(let* ((programs programs)
(id (secure-hash 'sha256 (prin1-to-string form)))
(counts (etaf-compiler--block-counts root)))
(cons (list :kind 'etaf/view-blueprint
@ -150,6 +205,100 @@
:hole-count (length programs))
programs))))
(defun etaf-compiler--closed-plist-p (value allowed)
"Return non-nil when VALUE is a duplicate-free plist using ALLOWED keys."
(and (proper-list-p value)
(zerop (% (length value) 2))
(let ((tail value)
seen
valid)
(setq valid t)
(while (and valid tail)
(let ((key (pop tail)))
(pop tail)
(if (or (not (memq key allowed)) (memq key seen))
(setq valid nil)
(push key seen))))
valid)))
(defun etaf-compiler--valid-property-descriptor-p (descriptor hole-count)
"Return non-nil for one bounded property DESCRIPTOR using HOLE-COUNT."
(and (proper-list-p descriptor)
(pcase (plist-get descriptor :kind)
('static
(and (etaf-compiler--closed-plist-p descriptor '(:kind :value))
(plist-member descriptor :value)))
('hole
(and (etaf-compiler--closed-plist-p descriptor '(:kind :index))
(natnump (plist-get descriptor :index))
(< (plist-get descriptor :index) hole-count)))
(_ nil))))
(defun etaf-compiler--valid-property-block-p (props hole-count)
"Return non-nil for a canonical property block PROPS using HOLE-COUNT."
(and (proper-list-p props)
(zerop (% (length props) 2))
(let ((tail props)
seen
valid)
(setq valid t)
(while (and valid tail)
(let ((key (pop tail))
(descriptor (pop tail)))
(if (or (not (keywordp key))
(memq key seen)
(not (etaf-compiler--valid-property-descriptor-p
descriptor hole-count)))
(setq valid nil)
(push key seen))))
valid)))
(defun etaf-compiler--valid-block-p (block hole-count)
"Return non-nil when BLOCK is valid for current View IR HOLE-COUNT."
(and (proper-list-p block)
(proper-list-p (plist-get block :path))
(booleanp (plist-get block :static-p))
(pcase (plist-get block :kind)
('literal
(and (etaf-compiler--closed-plist-p
block '(:kind :value :path :static-p))
(plist-member block :value)
(or (null (plist-get block :value))
(stringp (plist-get block :value)))
(plist-get block :static-p)))
((or 'expr 'branch 'keyed-list 'slot)
(and (etaf-compiler--closed-plist-p
block '(:kind :path :hole :static-p))
(natnump (plist-get block :hole))
(< (plist-get block :hole) hole-count)
(not (plist-get block :static-p))))
('node
(and (etaf-compiler--closed-plist-p
block '(:kind :name :path :props :children :static-p))
(symbolp (plist-get block :name))
(etaf-compiler--valid-property-block-p
(plist-get block :props) hole-count)
(proper-list-p (plist-get block :children))
(cl-every (lambda (child)
(etaf-compiler--valid-block-p child hole-count))
(plist-get block :children))))
(_ nil))))
(defun etaf-compiler--valid-blueprint-p (blueprint program-count)
"Return non-nil when BLUEPRINT is closed and matches PROGRAM-COUNT."
(and (etaf-compiler--closed-plist-p
blueprint
'(:kind :abi :id :root :static-nodes :dynamic-nodes :hole-count))
(eq (plist-get blueprint :kind) 'etaf/view-blueprint)
(equal (plist-get blueprint :abi) etaf-compiler-blueprint-abi)
(stringp (plist-get blueprint :id))
(natnump (plist-get blueprint :static-nodes))
(natnump (plist-get blueprint :dynamic-nodes))
(natnump (plist-get blueprint :hole-count))
(= program-count (plist-get blueprint :hole-count))
(etaf-compiler--valid-block-p
(plist-get blueprint :root) program-count)))
(defun etaf-compiler--materialize (blueprint block programs)
"Materialize BLOCK from BLUEPRINT using PROGRAMS."
(let* ((static-p (plist-get block :static-p))
@ -171,6 +320,22 @@
(plist-get blueprint :id)
(plist-get block :path))
:thunk (aref programs (plist-get block :hole))))
((or 'branch 'keyed-list)
(let ((program
(funcall (aref programs (plist-get block :hole)))))
(unless (and (etaf--expr-p program)
(eq (etaf--expr-kind program)
(plist-get block :kind)))
(error "Invalid ETAF structural program for %S"
(plist-get block :kind)))
program))
('slot
(let ((slot
(funcall (aref programs (plist-get block :hole)))))
(unless (or (etaf--slot-projection-p slot)
(etaf--slot-input-p slot))
(error "Invalid ETAF slot program"))
slot))
('node
(let ((props nil))
(cl-loop for (key descriptor) on (plist-get block :props)
@ -205,12 +370,9 @@
;;;###autoload
(defun etaf-compiler-instantiate (blueprint programs)
"Instantiate automatically lowered View BLUEPRINT with dynamic PROGRAMS."
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint)
(equal (plist-get blueprint :abi)
etaf-compiler-blueprint-abi)
(stringp (plist-get blueprint :id))
(vectorp programs)
(= (length programs) (plist-get blueprint :hole-count)))
(unless (and (vectorp programs)
(etaf-compiler--valid-blueprint-p
blueprint (length programs)))
(error "Invalid or incompatible ETAF View blueprint"))
(cl-incf etaf-compiler--instantiate-count)
(setq etaf-compiler--last-blueprint blueprint)
@ -219,14 +381,12 @@
(defun etaf-compiler-expand-view (form &optional slot-mode)
"Return compiler expansion for View FORM.
SLOT-MODE is forwarded to the legacy compiler."
(let* ((compiled (etaf-compiler--compile form))
(blueprint (car compiled))
(legacy (etaf--compile-view-form form (or slot-mode :projection))))
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint))
`(etaf-compiler-instantiate
',blueprint (vector ,@(cdr compiled)))
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy))))
SLOT-MODE distinguishes Component projections from call-site slot inputs."
(let* ((compiled (etaf-compiler--compile
form (or slot-mode :projection)))
(blueprint (car compiled)))
`(etaf-compiler-instantiate
',blueprint (vector ,@(cdr compiled)))))
(provide 'etaf-compiler)
;;; etaf-compiler.el ends here

122
etaf-component.el
View File

@ -4,15 +4,15 @@
;;; Commentary:
;; Components have one public definition boundary. A stateless Component
;; declares `:view'; a stateful Component declares `:setup' which runs once
;; per retained instance and returns a render function. Both forms produce
;; the same normalized View tree and share props, slots, styles, and Context.
;; Components have one public definition boundary with two strict authoring
;; frontends: compiled `:view' DSL and ordinary Elisp `:render'. Optional
;; `:setup' runs once and returns opaque state read through `etaf-state'.
;;; Code:
(require 'cl-lib)
(require 'etaf-view)
(require 'etaf-compiler)
(define-error 'etaf-component-definition-error
"Invalid ETAF Component definition"
@ -25,6 +25,22 @@
(defvar etaf--raw-slot-read-p nil
"Set while a Component render uses public raw slot accessors.")
(defvar etaf--component-phase nil
"Dynamic Component phase, either `setup', `render', or nil.")
(defvar etaf--current-component-state nil
"Opaque setup result supplied by the current Runtime Component context.")
(defvar etaf--current-component-setup-defined-p nil
"Whether the current Component definition declares setup.")
(defvar etaf--current-component-setup-complete-p nil
"Whether the current Component instance completed setup.")
(defconst etaf--component-reserved-props
'(key if else-if else for)
"Framework names forbidden in Component business prop declarations.")
(defun etaf--component-definition-error (format-string &rest arguments)
"Signal a Component definition error from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-component-definition-error
@ -51,6 +67,9 @@
(when (memq entry prop-names)
(etaf--component-definition-error
"Duplicate Component prop: %S" entry))
(when (memq entry etaf--component-reserved-props)
(etaf--component-definition-error
"Component prop %S is reserved by the View grammar" entry))
(push entry prop-names))
(nreverse prop-names)))
@ -68,6 +87,23 @@ The function is also useful to code that deliberately avoids that shorthand."
(plist-get etaf--current-component-props
(etaf--component-prop-key name)))
;;;###autoload
(defun etaf-state ()
"Return the current Component instance's exact setup result.
The accessor is valid only while rendering a Component that declares setup.
A defined setup may return nil; setup presence is tracked independently."
(unless (and (eq etaf--component-phase 'render)
etaf--current-component-instance)
(etaf--component-definition-error
"etaf-state is available only during Component view/render"))
(unless etaf--current-component-setup-defined-p
(etaf--component-definition-error
"Current Component does not declare :setup"))
(unless etaf--current-component-setup-complete-p
(etaf--component-definition-error
"Current Component setup has not completed"))
etaf--current-component-state)
;;;###autoload
(defun etaf-component-set-styles (name styles)
"Replace the static style form for Component NAME with STYLES.
@ -110,6 +146,9 @@ does not depend on ETAF's private registry flag."
(defun etaf-current-slots ()
"Return the current Component's normalized slot alist."
(unless (eq etaf--component-phase 'render)
(etaf--component-definition-error
"Slots are available only during Component view/render"))
(setq etaf--raw-slot-read-p t)
(mapcar (lambda (entry)
(cons (car entry)
@ -120,6 +159,9 @@ does not depend on ETAF's private registry flag."
(defun etaf-current-slot (name &optional fallback)
"Return the child list for slot NAME, or FALLBACK when it is absent."
(unless (eq etaf--component-phase 'render)
(etaf--component-definition-error
"Slots are available only during Component view/render"))
(setq etaf--raw-slot-read-p t)
(let ((entry (assq name etaf--current-component-slots)))
(if entry
@ -158,34 +200,48 @@ does not depend on ETAF's private registry flag."
name key)))))))
form)
(defun etaf--component-form-contains-head-p (form heads)
"Return non-nil when executable FORM contains a call headed by HEADS."
(cond
((atom form) nil)
((memq (car form) '(quote function)) nil)
((memq (car form) heads) t)
(t (cl-some (lambda (part)
(etaf--component-form-contains-head-p part heads))
form))))
;;;###autoload
(defmacro etaf-define-component (name arguments &rest clauses)
"Define Component NAME from prop ARGUMENTS and CLAUSES.
The definition boundary is intentionally small:
Choose exactly one authoring frontend:
(etaf-define-component NAME (&key PROPS)
[:setup SETUP]
:view VIEW
:styles (styles (SELECTOR ATTR ...)))
or:
(etaf-define-component NAME (&key PROPS)
:setup SETUP
[:setup SETUP]
:render ORDINARY-ELISP
:styles (styles (SELECTOR ATTR ...)))
`:view' is rendered for every update. `:setup' runs once per retained
Component instance and must return a zero-argument render function. View
forms do not use quote; ordinary Elisp belongs in `expr :value'."
`:setup' runs once per retained identity and returns opaque state. `:view'
is unquoted DSL; `:render' is ordinary Elisp and constructs nodes with
`etaf-node'."
(declare (indent 2) (debug defun))
(unless (symbolp name)
(etaf--component-definition-error
"Component name must be a symbol: %S" name))
(let ((docstring (when (stringp (car clauses)) (pop clauses)))
view-form
render-form
setup-form
styles-form
saw-view
saw-render
saw-setup
saw-styles)
(while clauses
@ -202,6 +258,11 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(etaf--component-definition-error
"Component %S has duplicate :view" name))
(setq view-form (pop clauses) saw-view t))
(:render
(when saw-render
(etaf--component-definition-error
"Component %S has duplicate :render" name))
(setq render-form (pop clauses) saw-render t))
(:setup
(when saw-setup
(etaf--component-definition-error
@ -215,31 +276,48 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(_
(etaf--component-definition-error
"Unknown Component definition keyword %S" keyword)))))
(when (and saw-view saw-setup)
(when (and saw-view saw-render)
(etaf--component-definition-error
"Component %S must choose :view or :setup, not both" name))
(unless (or saw-view saw-setup)
"Component %S must choose :view or :render, not both" name))
(unless (or saw-view saw-render)
(etaf--component-definition-error
"Component %S requires exactly one of :view or :setup" name))
"Component %S requires exactly one of :view or :render" name))
(when (and saw-setup
(etaf--component-form-contains-head-p
setup-form '(etaf-view etaf-node)))
(etaf--component-definition-error
"Component %S :setup cannot construct View structure" name))
(when (and saw-setup
(consp setup-form)
(memq (car setup-form) '(lambda function)))
(etaf--component-definition-error
"Component %S :setup cannot return a render function" name))
(when (and saw-render
(etaf--component-form-contains-head-p render-form '(etaf-view)))
(etaf--component-definition-error
"Component %S :render cannot embed the DSL frontend" name))
(let* ((props (etaf--parse-component-props arguments))
(styles-form (etaf--validate-styles-form styles-form name))
(definition-symbol
(intern (format "%s--etaf-component-definition" name)))
(render-lambda
(when saw-view
`(lambda (etaf--component-props etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots)
(etaf--current-component-instance
etaf--current-component-instance))
`(lambda (etaf--component-props etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots)
(etaf--component-phase 'render))
(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,(etaf--compile-view-form view-form :projection))))))
,(if saw-view
(let ((etaf--compiling-component-props props))
(etaf-compiler-expand-view
view-form :projection))
render-form)))))
(setup-lambda
(when saw-setup
`(lambda (etaf--component-props etaf--component-slots)
`(lambda (etaf--component-props _etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots))
(etaf--current-component-slots nil)
(etaf--component-phase 'setup))
(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,setup-form))))))

1
etaf-context.el
View File

@ -73,6 +73,7 @@ unchanged.")
;;;###autoload
(defun etaf-provide (key value)
"Provide VALUE under stable Context KEY to the current subtree."
(etaf--assert-not-rendering 'provide-context)
(unless (etaf-context-p etaf--current-context)
(error "ETAF provide requires Component setup or render context"))
(puthash (etaf--context-key key) value

1
etaf-events.el
View File

@ -65,6 +65,7 @@
When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
otherwise call the local callback with no arguments."
(etaf--assert-not-rendering 'dispatch-event)
(setq runtime (etaf-runtime-require-mounted runtime))
(let ((dispatch
(lambda ()

18
etaf-reactive.el
View File

@ -14,9 +14,12 @@
(require 'gv)
(define-error 'etaf-reactive-error "Invalid ETAF reactive operation")
(define-error 'etaf-render-side-effect-error
"ETAF render must be side-effect free"
'etaf-reactive-error)
(define-error 'etaf-render-write-error
"ETAF state cannot be written while rendering"
'etaf-reactive-error)
'etaf-render-side-effect-error)
(cl-defstruct (etaf-ref
(:constructor etaf--ref-create))
@ -93,6 +96,11 @@
(defvar etaf--render-phase-p nil
"Whether the current call is producing a View tree.")
(defun etaf--assert-not-rendering (operation)
"Reject detectable side-effect OPERATION during pure render."
(when etaf--render-phase-p
(signal 'etaf-render-side-effect-error (list operation))))
(defvar etaf--watch-scheduler nil
"Scheduler for watchers created in the current Scope.
@ -222,6 +230,7 @@ Runtime, watchers run synchronously.")
SCHEDULER receives the effect when a dependency changes. SCOPE defaults to
the current Scope. NAME optionally labels the effect. ON-STOP runs once
when the effect is disposed."
(etaf--assert-not-rendering 'create-effect)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let* ((owner (or scope etaf--active-scope))
@ -294,6 +303,7 @@ of the run."
"Create a writable shallow reactive cell containing INITIAL-VALUE.
TEST optionally compares old and new values. NAME is used in diagnostics."
(etaf--assert-not-rendering 'create-ref)
(when (and test (not (functionp test)))
(signal 'wrong-type-argument (list 'functionp test)))
(etaf--ref-create :value initial-value
@ -330,6 +340,7 @@ TEST optionally compares old and new values. NAME is used in diagnostics."
TEST optionally compares old and new values. NAME optionally labels the
computed value."
(etaf--assert-not-rendering 'create-computed)
(unless (functionp getter)
(signal 'wrong-type-argument (list 'functionp getter)))
(when (and test (not (functionp test)))
@ -398,6 +409,7 @@ computed value."
IMMEDIATE calls CALLBACK for the initial value. FLUSH is passed to the
current Runtime scheduler. TEST and NAME customize comparison and
diagnostics. Return a stop function."
(etaf--assert-not-rendering 'watch)
(unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback)))
(let* ((getter (etaf--watch-getter source))
@ -444,6 +456,7 @@ diagnostics. Return a stop function."
FLUSH selects the Runtime scheduler boundary. NAME optionally labels the
effect. If FUNCTION returns a function, it cleans up the previous run."
(etaf--assert-not-rendering 'watch-effect)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let (cleanup effect job)
@ -466,6 +479,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload
(cl-defun etaf-effect-scope (&key detached name)
"Create a Scope named NAME, owned by the current Scope unless DETACHED."
(etaf--assert-not-rendering 'create-scope)
(let* ((parent (and (not detached) etaf--active-scope))
(scope (etaf--effect-scope-create :parent parent :name name)))
(when parent
@ -492,6 +506,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload
(defun etaf-on-scope-dispose (function)
"Register FUNCTION to run when the current Scope is disposed."
(etaf--assert-not-rendering 'register-scope-cleanup)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(unless etaf--active-scope
@ -502,6 +517,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload
(defun etaf-scope-stop (scope)
"Dispose SCOPE and return cleanup errors collected during teardown."
(etaf--assert-not-rendering 'stop-scope)
(when (and (etaf-effect-scope-p scope)
(etaf-effect-scope-active-p scope))
(setf (etaf-effect-scope-active-p scope) nil)

36
etaf-renderer.el
View File

@ -334,7 +334,8 @@ Only strings and `expr' values that resolve to strings are compatible. View
structure must use the ordinary typed lowering path."
(cond
((stringp value) (cons t value))
((etaf--expr-p value)
((and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation))
(let ((result (funcall (etaf--expr-thunk value))))
(if (stringp result) (cons t result) (cons nil nil))))
((etaf--view-node-p value) (cons nil nil))
@ -351,7 +352,9 @@ structure must use the ordinary typed lowering path."
(defun etaf--inline-text-structural-p (value)
"Return non-nil when VALUE can be owned by mounted inline effects."
(cond
((or (null value) (stringp value) (etaf--expr-p value)) t)
((or (null value) (stringp value)
(and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation))) t)
((etaf--view-node-p value) nil)
((proper-list-p value)
(cl-every #'etaf--inline-text-structural-p value))
@ -360,7 +363,8 @@ structure must use the ordinary typed lowering path."
(defun etaf--inline-text-dynamic-p (value)
"Return non-nil when VALUE contains an inline `expr' update site."
(cond
((etaf--expr-p value) t)
((and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation)) t)
((etaf--view-node-p value)
(cl-some #'etaf--inline-text-dynamic-p
(etaf--view-node-children value)))
@ -533,7 +537,25 @@ multi-root forest; a single material root is returned unchanged."
(etaf--component-call-p value) (etaf--slot-projection-p value))
(list value))
((etaf--expr-p value)
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
(pcase (etaf--expr-kind value)
('interpolation
(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)))))))
('branch
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
('keyed-list
(let ((snapshot (etaf--keyed-program-snapshot value)))
(etaf--flatten-view-value
(etaf--keyed-program-outputs value snapshot))))
(_ (signal 'etaf-renderer-error
(list (format "Unknown View program: %S" value))))))
((proper-list-p value)
(cl-mapcan #'etaf--flatten-view-value value))
(t
@ -597,7 +619,8 @@ multi-root forest; a single material root is returned unchanged."
(let ((etaf--current-component-props
(etaf--component-call-props call))
(etaf--current-component-slots
(etaf--component-call-slots call)))
(etaf--component-call-slots call))
(etaf--component-phase 'render))
(let ((etaf--render-parent-style-stack etaf--render-style-stack)
(etaf--render-style-stack
(list (cons (etaf--component-spec-styles spec)
@ -739,7 +762,8 @@ multi-root forest; a single material root is returned unchanged."
(let ((etaf--current-semantic-parent-id
(or semantic-id
etaf--current-semantic-parent-id)))
(if (and semantic-id (etaf--expr-p child)
(if (and semantic-id
(etaf--structural-program-p child)
(not etaf--rendering-range-p))
(let ((result
(etaf--runtime-render-child-range

3
etaf-resource.el
View File

@ -93,6 +93,7 @@ disposed."
The Resource owns a child Scope under SCOPE, or under the current active Scope
when SCOPE is nil. Without any parent Scope it creates a detached Scope.
When IMMEDIATE is non-nil, load the Resource before returning it."
(etaf--assert-not-rendering 'create-resource)
(unless (functionp loader)
(signal 'wrong-type-argument (list 'functionp loader)))
(let* ((parent (etaf--resource-parent-scope scope))
@ -137,6 +138,7 @@ When IMMEDIATE is non-nil, load the Resource before returning it."
Only LOADER errors are captured into Resource state. Cleanup failures and
wrong Resource usage continue to signal normally."
(etaf--assert-not-rendering 'load-resource)
(etaf--resource-require-active resource)
(etaf--resource-run-cleanup resource)
(etaf--resource-set-state resource 'loading nil nil)
@ -161,6 +163,7 @@ wrong Resource usage continue to signal normally."
;;;###autoload
(defun etaf-resource-dispose (resource)
"Dispose RESOURCE and return cleanup errors collected by its Scope."
(etaf--assert-not-rendering 'dispose-resource)
(unless (etaf-resource-p resource)
(signal 'wrong-type-argument (list 'etaf-resource-p resource)))
(when (etaf-resource-active-p resource)

468
etaf-runtime.el
View File

@ -57,7 +57,8 @@
spec
identity
scope
render-function
state
(setup-complete-p nil)
context
mounted-hooks
updated-hooks
@ -88,10 +89,10 @@
(cl-defstruct (etaf--semantic-range (:constructor etaf--semantic-range-create))
semantic-id identity effect-id kind parent-id component-id token range-ref
path caller-style-stack output-signature deps artifact-key item-host-ids
path caller-style-stack output-signature deps artifact-key item-root-ids
item-identity-index context-deps
keyed-context-signature keyed-item-signatures keyed-item-id-index
keyed-key-order
keyed-context-signature keyed-item-signatures keyed-item-root-id-index
keyed-item-node-span-index keyed-key-order
(composition-version 0))
(cl-defstruct (etaf--semantic-inline-range
@ -103,7 +104,7 @@
(:constructor etaf--semantic-slot-range-create))
semantic-id identity effect-id parent-id owner-component-id
consumer-component-id token name range-ref path style-stack
output-signature deps artifact-key item-host-ids item-identity-index
output-signature deps artifact-key item-root-ids item-identity-index
context-deps
(composition-version 0))
@ -165,9 +166,9 @@ the operation preserves committed values and removal semantics."
((etaf--semantic-host-p semantic)
(etaf--semantic-host-child-ids semantic))
((etaf--semantic-range-p semantic)
(etaf--semantic-range-item-host-ids semantic))
(etaf--semantic-range-item-root-ids semantic))
((etaf--semantic-slot-range-p semantic)
(etaf--semantic-slot-range-item-host-ids semantic))))
(etaf--semantic-slot-range-item-root-ids semantic))))
(defun etaf--generation-parent-id (generation semantic-id)
"Return SEMANTIC-ID's parent directly from GENERATION's semantic node."
@ -1350,6 +1351,16 @@ reading Runtime storage fields."
(funcall function))
(let ((etaf--current-runtime runtime)
(etaf--current-component-instance instance)
(etaf--current-component-state
(and instance (etaf--component-instance-state instance)))
(etaf--current-component-setup-defined-p
(and instance
(not (null (etaf--component-spec-setup
(etaf--component-instance-spec instance))))))
(etaf--current-component-setup-complete-p
(and instance
(etaf--component-instance-setup-complete-p instance)))
(etaf--component-phase 'render)
(etaf--current-component-identity identity)
(etaf--current-component-semantic-id component-id)
(etaf--current-component-props props)
@ -1842,6 +1853,17 @@ need to know how Behavior attributes are merged."
(append (butlast path) (list :key key))
path)))
(defun etaf--runtime-component-business-props (call)
"Return CALL props without framework-owned identity metadata."
(let ((tail (etaf--component-call-props call))
result)
(while tail
(let ((key (pop tail))
(value (pop tail)))
(unless (eq key :key)
(setq result (append result (list key value))))))
result))
(defun etaf--runtime-owned-slots (slots)
"Attach current caller ownership to unowned normalized SLOTS."
(mapcar
@ -1875,7 +1897,8 @@ need to know how Behavior attributes are merged."
(etaf--component-instance-create
:spec spec
:identity identity
:scope (etaf-effect-scope :name identity)
:scope (let ((etaf--render-phase-p nil))
(etaf-effect-scope :name identity))
:context (etaf--context-create :parent etaf--current-context)
:resource-key resource-key)))
(push instance (etaf-runtime-candidate-created runtime))
@ -1923,6 +1946,12 @@ need to know how Behavior attributes are merged."
(etaf--component-instance-context instance))))
(let ((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 setup)))
(etaf--current-component-setup-complete-p
(etaf--component-instance-setup-complete-p instance))
(etaf--component-phase 'render)
(etaf--current-component-identity identity)
(etaf--current-component-props props)
(etaf--current-component-slots slots)
@ -1935,31 +1964,34 @@ need to know how Behavior attributes are merged."
(cons (etaf--component-spec-styles spec)
(append path (list :view))))))
(when (and setup
(null (etaf--component-instance-render-function instance)))
(let ((render-function
(not (etaf--component-instance-setup-complete-p instance)))
(let ((state
(etaf-scope-run
(etaf--component-instance-scope instance)
(lambda ()
(let ((etaf--runtime-dependency-collector nil)
(etaf--tracking-enabled-p nil)
(etaf--active-effect nil))
(etaf--active-effect nil)
(etaf--render-phase-p nil)
(etaf--component-phase 'setup))
(funcall setup props slots)))
:watch-scheduler
(lambda (job phase)
(etaf--runtime-watch-scheduler runtime job phase)))))
(unless (functionp render-function)
(when (functionp state)
(signal 'etaf-runtime-error
(list (format
"Component %S :setup must return a render function"
"Component %S :setup returned a function"
(etaf--component-spec-name spec)))))
(setf (etaf--component-instance-render-function instance)
render-function)))
(let* ((render-function
(or (etaf--component-instance-render-function instance)
(etaf--component-spec-render spec)))
(rendered (if setup
(funcall render-function)
(funcall render-function props slots)))
(setf (etaf--component-instance-state instance) state
(etaf--component-instance-setup-complete-p instance) t
etaf--current-component-state state
etaf--current-component-setup-complete-p t)))
(let* ((render-function (etaf--component-spec-render spec))
(rendered
(etaf--validate-component-render-result
(funcall render-function props slots)
(etaf--component-spec-name spec)))
(transparent-p
(and (not (eq old-publication-kind 'material))
(etaf--runtime-transparent-output-p rendered)))
@ -2131,7 +2163,7 @@ need to know how Behavior attributes are merged."
:output-signature (copy-tree rendered) :deps nil
:artifact-key (list (1+ (etaf-runtime-generation runtime))
'component-output effect-id)
:item-host-ids child-ids :item-identity-index item-index)))
:item-root-ids child-ids :item-identity-index item-index)))
(dolist (child-id child-ids)
(when-let* ((child (gethash child-id
(etaf-runtime-candidate-graph-nodes runtime))))
@ -2158,7 +2190,7 @@ need to know how Behavior attributes are merged."
(dolist (old-id
(etaf--runtime-generation-descendant-ids
(etaf-runtime-current-generation runtime)
(etaf--semantic-range-item-host-ids old-range)))
(etaf--semantic-range-item-root-ids old-range)))
(unless (gethash old-id new-set)
(push old-id
(etaf-runtime-candidate-removed-semantic-ids runtime))))))
@ -2226,6 +2258,7 @@ need to know how Behavior attributes are merged."
(cl-incf (etaf-runtime-next-effect-id runtime))))
(semantic-id (or (and old (etaf--semantic-component-semantic-id old))
(cl-incf (etaf-runtime-next-semantic-id runtime))))
(input-props (etaf--runtime-component-business-props call))
props input-deps render-deps context-deps slot-retargeted-p)
(unless (etaf-context-owner-id (etaf--component-instance-context instance))
(setf (etaf-context-owner-id (etaf--component-instance-context instance))
@ -2239,7 +2272,7 @@ need to know how Behavior attributes are merged."
(etaf--active-effect nil)
(etaf--render-phase-p t))
(setq props
(etaf--resolve-property-plist (etaf--component-call-props call))))
(etaf--resolve-property-plist input-props)))
(puthash semantic-id
(list :identity identity :instance instance :props props :slots slots)
(etaf-runtime-candidate-component-envs runtime))
@ -2263,7 +2296,8 @@ need to know how Behavior attributes are merged."
(not (equal-including-properties
slots (etaf--semantic-component-slots old))))))
(progn
(when (etaf-runtime-candidate-full-rebuild-p runtime)
(when (or (etaf-runtime-candidate-full-rebuild-p runtime)
etaf--rendering-range-p)
(etaf--runtime-carry-committed-subtree runtime old-generation old))
(if (eq (etaf--semantic-component-publication-kind old) 'transparent)
(let* ((range
@ -2356,7 +2390,7 @@ need to know how Behavior attributes are merged."
:resource-key
(copy-tree (etaf--component-instance-resource-key instance))
:props (copy-tree props) :slots (copy-tree slots)
:input-props (copy-tree (etaf--component-call-props call))
:input-props (copy-tree input-props)
:input-slots (copy-tree slots)
:output-signature (copy-tree output-signature)
:artifact-key (and (not transparent-p) effect-id)
@ -2588,9 +2622,9 @@ need to know how Behavior attributes are merged."
((etaf--semantic-host-p semantic)
(etaf--semantic-host-child-ids semantic))
((etaf--semantic-range-p semantic)
(etaf--semantic-range-item-host-ids semantic))
(etaf--semantic-range-item-root-ids semantic))
((etaf--semantic-slot-range-p semantic)
(etaf--semantic-slot-range-item-host-ids semantic))
(etaf--semantic-slot-range-item-root-ids semantic))
(t nil))))
(unless (and (etaf--semantic-host-p semantic)
(etaf--semantic-range-p
@ -2708,6 +2742,7 @@ 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)
(not (gethash effect-id (etaf-runtime-dirty-effect-ids runtime))))
(progn
(puthash identity semantic-id
@ -2721,7 +2756,7 @@ need to know how Behavior attributes are merged."
(apply #'ebox-child-range range-ref
(copy-sequence
(etaf--runtime-range-nodes runtime old))))))
(let (deps context-deps value nodes keyed-snapshot)
(let (deps context-deps value nodes keyed-snapshot range-render)
(let ((collector
(lambda (source) (cl-pushnew source deps :test #'eq))))
(let ((etaf--runtime-dependency-collector collector)
@ -2731,11 +2766,13 @@ need to know how Behavior attributes are merged."
context-deps :test #'equal)))
(etaf--active-effect nil)
(etaf--render-phase-p t))
(setq keyed-snapshot
(etaf--runtime-keyed-range-snapshot expr))
(setq value
(etaf--runtime-normalize-range-value
(funcall (etaf--expr-thunk expr))))
(setq keyed-snapshot
(etaf--runtime-keyed-range-snapshot expr)))
(if keyed-snapshot
(etaf--keyed-program-outputs expr keyed-snapshot)
(funcall (etaf--expr-thunk expr))))))
(puthash identity semantic-id
(etaf-runtime-candidate-identity-entries runtime))
(etaf--runtime-candidate-add-child
@ -2751,19 +2788,22 @@ need to know how Behavior attributes are merged."
(etaf--rendering-range-p t)
(etaf--active-effect nil)
(etaf--render-phase-p t))
(setq nodes
(setq range-render
(etaf--runtime-render-range-items
value path expr keyed-snapshot))))
(let* ((item-host-ids
value path expr keyed-snapshot)
nodes (plist-get range-render :nodes))))
(let* ((item-root-ids
(copy-sequence
(gethash semantic-id
(etaf-runtime-candidate-graph-children runtime))))
(all-item-ids
(etaf--runtime-candidate-descendant-ids runtime item-host-ids))
(etaf--runtime-candidate-descendant-ids runtime item-root-ids))
(item-index (make-hash-table :test #'equal))
(keyed
(etaf--runtime-keyed-range-metadata
expr keyed-snapshot item-host-ids))
expr keyed-snapshot
(plist-get range-render :item-root-groups)
(plist-get range-render :item-node-counts)))
(record
(etaf--semantic-range-create
:semantic-id semantic-id :identity identity :effect-id effect-id
@ -2776,30 +2816,23 @@ need to know how Behavior attributes are merged."
:context-deps (nreverse context-deps)
:artifact-key (cons (1+ (etaf-runtime-generation runtime))
effect-id)
:item-host-ids item-host-ids
:item-root-ids item-root-ids
:item-identity-index item-index
:keyed-context-signature (plist-get keyed :context)
:keyed-item-signatures (plist-get keyed :signatures)
:keyed-item-id-index (plist-get keyed :id-index)
:keyed-item-root-id-index (plist-get keyed :root-id-index)
:keyed-item-node-span-index
(plist-get keyed :node-span-index)
:keyed-key-order (plist-get keyed :keys))))
(unless (= (length nodes) (length item-host-ids))
(signal 'etaf-runtime-error
(list "Direct child Range items must be Host Views"
(length nodes) (length item-host-ids))))
(dolist (item-id all-item-ids)
(let ((item (gethash item-id
(etaf-runtime-candidate-graph-nodes runtime))))
(unless (etaf--semantic-host-p item)
(signal 'etaf-runtime-error
(list "Direct child Range items must be Host Views")))
(puthash (etaf--semantic-host-identity item) item-id item-index)))
(etaf--runtime-index-range-item-identities
runtime all-item-ids item-index)
(when old
(let ((new-set (make-hash-table :test #'eql)))
(dolist (item-id all-item-ids) (puthash item-id t new-set))
(dolist (old-id
(etaf--runtime-generation-descendant-ids
old-generation
(etaf--semantic-range-item-host-ids old)))
(etaf--semantic-range-item-root-ids old)))
(unless (gethash old-id new-set)
(push old-id
(etaf-runtime-candidate-removed-semantic-ids runtime))))))
@ -2937,7 +2970,7 @@ The candidate uses resolved VALUE, DEPS, and NODES."
:output-signature (copy-tree value) :deps deps
:context-deps context-deps
:artifact-key (cons (1+ (etaf-runtime-generation runtime)) effect-id)
:item-host-ids item-host-ids :item-identity-index item-index)))
:item-root-ids item-host-ids :item-identity-index item-index)))
(dolist (item-id all-item-ids)
(let ((item (gethash item-id
(etaf-runtime-candidate-graph-nodes runtime))))
@ -2950,7 +2983,7 @@ The candidate uses resolved VALUE, DEPS, and NODES."
(dolist (item-id all-item-ids) (puthash item-id t new-set))
(dolist (old-item-id
(etaf--runtime-generation-descendant-ids
generation (etaf--semantic-slot-range-item-host-ids old)))
generation (etaf--semantic-slot-range-item-root-ids old)))
(unless (gethash old-item-id new-set)
(push old-item-id
(etaf-runtime-candidate-removed-semantic-ids runtime))))))
@ -3021,6 +3054,9 @@ The candidate uses resolved VALUE, DEPS, and NODES."
(cond
((null value) nil)
((stringp value) (list value))
((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--view-node-p value)
@ -3040,7 +3076,9 @@ The candidate uses resolved VALUE, DEPS, and NODES."
(defun etaf--runtime-keyed-range-snapshot (expr)
"Return EXPR's validated keyed Range snapshot, or nil."
(when-let* ((snapshot-function (etaf--expr-range-snapshot expr)))
(if (eq (etaf--expr-kind expr) 'keyed-list)
(etaf--keyed-program-snapshot expr)
(when-let* ((snapshot-function (etaf--expr-range-snapshot expr)))
(let ((key-function (etaf--expr-range-key expr))
(item-function (etaf--expr-range-item expr))
(snapshot (funcall snapshot-function)))
@ -3052,7 +3090,18 @@ The candidate uses resolved VALUE, DEPS, and NODES."
(proper-list-p (plist-get snapshot :items)))
(signal 'etaf-runtime-error
(list "Invalid keyed Range program snapshot")))
snapshot))))
snapshot)))))
(defun etaf--runtime-keyed-range-keys (expr snapshot)
"Return validated keys for EXPR aligned with keyed SNAPSHOT items."
(or (plist-get snapshot :keys)
(let ((key-function (etaf--expr-range-key expr)))
(unless (functionp key-function)
(signal 'etaf-runtime-error
(list "Keyed Range lacks a key function")))
(mapcar (lambda (item)
(etaf--validate-key (funcall key-function item)))
(plist-get snapshot :items)))))
(defun etaf--runtime-keyed-range-item-path (path key)
"Return stable PATH below one keyed Range item KEY."
@ -3062,60 +3111,105 @@ The candidate uses resolved VALUE, DEPS, and NODES."
"Render normalized Range VALUE at PATH using optional keyed SNAPSHOT.
EXPR supplies the key function. Keyed item paths encode stable keys rather
than transient positions, so reordering changes geometry without changing any
generated descendant Host reference."
generated descendant identity. Return a plist containing flat backend NODES
and, for keyed input, the semantic root groups and backend node counts owned by
each logical item."
(if (null snapshot)
(etaf--render-value-list value path)
(list :nodes (etaf--render-value-list value path))
(let ((items (plist-get snapshot :items))
(key-function (etaf--expr-range-key expr))
(seen (make-hash-table :test #'equal)))
(unless (= (length value) (length items))
(keys (etaf--runtime-keyed-range-keys expr snapshot))
(seen (make-hash-table :test #'equal))
nodes root-groups node-counts)
(unless (and (= (length value) (length items))
(= (length items) (length keys)))
(signal 'etaf-runtime-error
(list "Keyed Range item/output cardinality mismatch")))
(cl-mapcan
(lambda (output item)
(let ((key (funcall key-function item)))
(unless key
(signal 'etaf-runtime-error
(list "Keyed Range key must be non-nil")))
(cl-mapc
(lambda (output _item key)
(let ((key (etaf--validate-key key)))
(when (gethash key seen)
(signal 'etaf-runtime-error
(list "Keyed Range keys must be unique" key)))
(puthash key t seen)
(etaf--render-value-list
output (etaf--runtime-keyed-range-item-path path key))))
value items))))
(let* ((before
(length
(gethash etaf--current-semantic-parent-id
(etaf-runtime-candidate-graph-children
etaf--render-runtime))))
(rendered
(etaf--render-value-list
output (etaf--runtime-keyed-range-item-path path key)))
(children
(gethash etaf--current-semantic-parent-id
(etaf-runtime-candidate-graph-children
etaf--render-runtime)))
(roots (copy-sequence (nthcdr before children))))
(setq nodes (nconc nodes rendered))
(push roots root-groups)
(push (length rendered) node-counts))))
value items keys)
(list :nodes nodes
:item-root-groups (nreverse root-groups)
:item-node-counts (nreverse node-counts)))))
(defun etaf--runtime-keyed-range-metadata
(expr snapshot item-host-ids)
"Return retained metadata for EXPR SNAPSHOT aligned to ITEM-HOST-IDS."
(expr snapshot item-root-groups item-node-counts)
"Return retained metadata for EXPR SNAPSHOT and aligned item spans."
(when snapshot
(let ((items (plist-get snapshot :items))
(key-function (etaf--expr-range-key expr))
(snapshot-keys (etaf--runtime-keyed-range-keys expr snapshot))
(signatures (make-hash-table :test #'equal))
(id-index (make-hash-table :test #'equal))
(root-id-index (make-hash-table :test #'equal))
(node-span-index (make-hash-table :test #'equal))
(seen (make-hash-table :test #'equal))
(node-offset 0)
keys)
(unless (= (length items) (length item-host-ids))
(unless (and (= (length items) (length item-root-groups))
(= (length items) (length item-node-counts)))
(signal 'etaf-runtime-error
(list "Keyed Range item/Host cardinality mismatch")))
(list "Keyed Range item/span cardinality mismatch")))
(cl-mapc
(lambda (item host-id)
(let ((key (funcall key-function item)))
(unless key
(signal 'etaf-runtime-error
(list "Keyed Range key must be non-nil")))
(lambda (item root-ids node-count key)
(let ((key (etaf--validate-key key)))
(when (gethash key seen)
(signal 'etaf-runtime-error
(list "Keyed Range keys must be unique" key)))
(unless (and (proper-list-p root-ids)
(natnump node-count))
(signal 'etaf-runtime-error
(list "Invalid keyed Range item span" key)))
(puthash key t seen)
(puthash key (copy-tree item) signatures)
(puthash key host-id id-index)
(puthash key (copy-sequence root-ids) root-id-index)
(puthash key (cons node-offset node-count) node-span-index)
(cl-incf node-offset node-count)
(push key keys)))
items item-host-ids)
items item-root-groups item-node-counts
snapshot-keys)
(list :context (copy-tree (plist-get snapshot :context))
:signatures signatures :id-index id-index
:signatures signatures
:root-id-index root-id-index
:node-span-index node-span-index
:keys (nreverse keys)))))
(defun etaf--runtime-index-range-item-identities
(runtime semantic-ids identity-index)
"Validate SEMANTIC-IDS and index their Host identities in IDENTITY-INDEX."
(dolist (semantic-id semantic-ids)
(let ((semantic
(gethash semantic-id
(etaf-runtime-candidate-graph-nodes runtime))))
(unless (or (etaf--semantic-host-p semantic)
(etaf--semantic-component-p semantic)
(etaf--semantic-range-p semantic)
(etaf--semantic-slot-range-p semantic)
(etaf--semantic-inline-range-p semantic))
(signal 'etaf-runtime-error
(list "Invalid semantic root below Range" semantic-id)))
(when (etaf--semantic-host-p semantic)
(puthash (etaf--semantic-host-identity semantic)
semantic-id identity-index)))))
(defun etaf--runtime-candidate-descendant-ids (runtime roots)
"Return ROOTS and all candidate semantic descendants in RUNTIME."
(let ((queue (copy-sequence roots)) result)
@ -3147,10 +3241,12 @@ generated descendant Host reference."
SURFACE is retained in the Range record for ABI stability but never applies
raw Emacs properties; Text presentation is projected by Ebox."
(ignore surface)
(if (stringp value)
value
(cond
((null value) "")
((stringp value) value)
(t
(signal 'etaf-runtime-error
(list "Text expr must resolve to one string"))))
(list "Text expr must resolve to nil or one string")))))
(defun etaf--runtime-render-inline-range
(runtime host-id expr path surface)
@ -3437,7 +3533,7 @@ raw Emacs properties; Text presentation is projected by Ebox."
:path '(root) :caller-style-stack nil
:output-signature (copy-tree (etaf-runtime-root-view-cache runtime))
:deps (copy-sequence deps) :artifact-key nil
:item-host-ids children
:item-root-ids children
:item-identity-index (make-hash-table :test #'equal))))
(puthash identity semantic-id
(etaf-runtime-candidate-identity-entries runtime))
@ -4395,11 +4491,17 @@ the range is not eligible for keyed incremental rendering."
(item-function (and (etaf--expr-p expr)
(etaf--expr-range-item expr)))
(old-signatures (etaf--semantic-range-keyed-item-signatures range))
(old-id-index (etaf--semantic-range-keyed-item-id-index range))
(old-root-id-index
(etaf--semantic-range-keyed-item-root-id-index range))
(old-node-span-index
(etaf--semantic-range-keyed-item-node-span-index range))
(old-keys (etaf--semantic-range-keyed-key-order range)))
(when (and snapshot-function key-function item-function
(when (and snapshot-function item-function
(or key-function (eq (etaf--expr-kind expr) 'keyed-list))
(hash-table-p old-signatures)
(hash-table-p old-id-index) old-keys)
(hash-table-p old-root-id-index)
(hash-table-p old-node-span-index)
(proper-list-p old-keys))
(let (deps context-deps snapshot)
(let ((etaf--runtime-dependency-collector
(lambda (source) (cl-pushnew source deps :test #'eq)))
@ -4409,6 +4511,14 @@ the range is not eligible for keyed incremental rendering."
context-deps :test #'equal)))
(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
@ -4423,6 +4533,8 @@ the range is not eligible for keyed incremental rendering."
(when snapshot
(let* ((generation (etaf-runtime-current-generation runtime))
(items (plist-get snapshot :items))
(snapshot-keys
(etaf--runtime-keyed-range-keys expr snapshot))
(context (plist-get snapshot :context))
(context-stable-p
(equal-including-properties
@ -4430,18 +4542,27 @@ the range is not eligible for keyed incremental rendering."
(etaf--semantic-range-keyed-context-signature range)))
(old-input (etaf--runtime-range-input runtime range))
(old-nodes (ebox-canonical-input-roots old-input))
(old-node-index (make-hash-table :test #'equal))
(old-key-position (make-hash-table :test #'equal))
(seen (make-hash-table :test #'equal))
nodes keys signatures reuse-map reused-roots)
(unless (= (length old-keys) (length old-nodes))
(missing (make-symbol "etaf-keyed-span-missing"))
(old-node-offset 0)
(new-node-offset 0)
nodes keys signatures reuse-map reused-roots
item-root-groups item-node-counts)
(dolist (key old-keys)
(let ((span (gethash key old-node-span-index missing)))
(unless (and (consp span)
(natnump (car span))
(natnump (cdr span))
(= (car span) old-node-offset)
(<= (+ (car span) (cdr span))
(length old-nodes)))
(signal 'etaf-runtime-error
(list "Keyed Range retained node spans are invalid"
key)))
(cl-incf old-node-offset (cdr span))))
(unless (= old-node-offset (length old-nodes))
(signal 'etaf-runtime-error
(list "Keyed Range retained artifact is misaligned")))
(cl-mapc (lambda (key node)
(puthash key node old-node-index))
old-keys old-nodes)
(cl-loop for key in old-keys for index from 0
do (puthash key index old-key-position))
(let ((etaf--runtime-dependency-collector
(lambda (source) (cl-pushnew source deps :test #'eq)))
(etaf--context-inject-recorder
@ -4465,18 +4586,20 @@ the range is not eligible for keyed incremental rendering."
(etaf--semantic-range-caller-style-stack range))))
(cl-loop
for item in items
for key in snapshot-keys
for index from 0
do
(let* ((key (funcall key-function item))
(let* ((key (etaf--validate-key key))
(old-signature (gethash key old-signatures))
(old-id (gethash key old-id-index))
(old-node (gethash key old-node-index))
(old-root-ids
(gethash key old-root-id-index missing))
(old-node-span
(gethash key old-node-span-index missing))
(reuse-p
(and context-stable-p old-id old-node
(and context-stable-p
(not (eq old-root-ids missing))
(not (eq old-node-span missing))
(equal-including-properties item old-signature))))
(unless key
(signal 'etaf-runtime-error
(list "Keyed Range key must be non-nil")))
(when (gethash key seen)
(signal 'etaf-runtime-error
(list "Keyed Range keys must be unique" key)))
@ -4484,43 +4607,75 @@ the range is not eligible for keyed incremental rendering."
(push key keys)
(push (copy-tree item) signatures)
(if reuse-p
(let ((semantic
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
old-id)))
(unless (etaf--semantic-host-p semantic)
(let* ((old-start (car old-node-span))
(old-count (cdr old-node-span))
(old-item-nodes
(cl-subseq old-nodes old-start
(+ old-start old-count))))
(unless (proper-list-p old-root-ids)
(signal 'etaf-runtime-error
(list "Keyed Range retained item is invalid"
(list "Keyed Range retained roots are invalid"
key)))
(etaf--runtime-candidate-add-child
runtime (etaf--semantic-range-semantic-id range) old-id)
(etaf--runtime-carry-committed-subtree
runtime generation semantic)
(push (cons index (gethash key old-key-position))
reuse-map)
(push old-node reused-roots)
(push old-node nodes))
(let* ((value
(dolist (old-root-id old-root-ids)
(let ((semantic
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
old-root-id)))
(unless semantic
(signal 'etaf-runtime-error
(list "Keyed Range retained root is missing"
key old-root-id)))
(etaf--runtime-candidate-add-child
runtime (etaf--semantic-range-semantic-id range)
old-root-id)
(etaf--runtime-carry-committed-subtree
runtime generation semantic)))
(cl-loop for offset below old-count
do (push
(cons (+ new-node-offset offset)
(+ old-start offset))
reuse-map))
(setq nodes (nconc nodes old-item-nodes)
reused-roots
(nconc reused-roots
(copy-sequence old-item-nodes)))
(push (copy-sequence old-root-ids) item-root-groups)
(push old-count item-node-counts)
(cl-incf new-node-offset old-count))
(let* ((before
(length
(gethash
(etaf--semantic-range-semantic-id range)
(etaf-runtime-candidate-graph-children runtime))))
(value
(etaf--runtime-normalize-range-value
(funcall item-function item context)))
(rendered
(etaf--render-value-list
value
(etaf--runtime-keyed-range-item-path
(etaf--semantic-range-path range) key))))
(unless (= (length rendered) 1)
(signal 'etaf-runtime-error
(list "Keyed Range item must render one Host"
key)))
(push (car rendered) nodes)))))
(etaf--semantic-range-path range) key)))
(children
(gethash
(etaf--semantic-range-semantic-id range)
(etaf-runtime-candidate-graph-children runtime)))
(root-ids
(copy-sequence (nthcdr before children)))
(node-count (length rendered)))
(setq nodes (nconc nodes rendered))
(push root-ids item-root-groups)
(push node-count item-node-counts)
(cl-incf new-node-offset node-count)))))
(ebox-canonical-input-import-roots
old-input (nreverse reused-roots) etaf--ebox-source-builder)
(list :nodes (nreverse nodes)
old-input reused-roots etaf--ebox-source-builder)
(list :nodes nodes
:snapshot snapshot
:value (list :keyed-range
(copy-tree context)
(nreverse keys)
(nreverse signatures))
:item-root-groups (nreverse item-root-groups)
:item-node-counts (nreverse item-node-counts)
:deps (nreverse deps)
:context-deps (nreverse context-deps)
:reuse-map (nreverse reuse-map)))))))))
@ -4539,7 +4694,8 @@ the range is not eligible for keyed incremental rendering."
(gethash (etaf--semantic-component-resource-key component)
(etaf-runtime-resource-registry runtime)))
(builder (ebox-source-builder-create))
deps context-deps value nodes keyed-snapshot)
deps context-deps value nodes keyed-snapshot
item-root-groups item-node-counts)
(let ((etaf--ebox-source-builder builder))
(let ((keyed
(etaf--runtime-render-keyed-range
@ -4549,7 +4705,9 @@ the range is not eligible for keyed incremental rendering."
context-deps (plist-get keyed :context-deps)
value (plist-get keyed :value)
nodes (plist-get keyed :nodes)
keyed-snapshot (plist-get keyed :snapshot))
keyed-snapshot (plist-get keyed :snapshot)
item-root-groups (plist-get keyed :item-root-groups)
item-node-counts (plist-get keyed :item-node-counts))
(let ((collector
(lambda (source) (cl-pushnew source deps :test #'eq))))
(let ((etaf--runtime-dependency-collector collector)
@ -4559,6 +4717,14 @@ the range is not eligible for keyed incremental rendering."
context-deps :test #'equal)))
(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
@ -4599,36 +4765,27 @@ the range is not eligible for keyed incremental rendering."
(copy-tree (etaf--semantic-range-caller-style-stack range))))
(setq nodes (etaf--render-value-list
value (etaf--semantic-range-path range))))))
(let* ((item-host-ids
(let* ((item-root-ids
(copy-sequence
(gethash (etaf--semantic-range-semantic-id range)
(etaf-runtime-candidate-graph-children runtime))))
(all-item-ids
(etaf--runtime-candidate-descendant-ids runtime item-host-ids))
(etaf--runtime-candidate-descendant-ids runtime item-root-ids))
(item-index (make-hash-table :test #'equal))
(keyed-metadata
(and keyed-snapshot
(etaf--runtime-keyed-range-metadata
(etaf--generation-effect-target effect)
keyed-snapshot item-host-ids)))
keyed-snapshot item-root-groups item-node-counts)))
(candidate (copy-sequence range)))
(unless (= (length nodes) (length item-host-ids))
(signal 'etaf-runtime-error
(list "Direct child Range items must be Host Views"
(length nodes) (length item-host-ids))))
(dolist (item-id all-item-ids)
(let ((item (gethash item-id
(etaf-runtime-candidate-graph-nodes runtime))))
(unless (etaf--semantic-host-p item)
(signal 'etaf-runtime-error
(list "Direct child Range items must be Host Views")))
(puthash (etaf--semantic-host-identity item) item-id item-index)))
(etaf--runtime-index-range-item-identities
runtime all-item-ids item-index)
(let ((new-set (make-hash-table :test #'eql)))
(dolist (item-id all-item-ids) (puthash item-id t new-set))
(dolist (old-id
(etaf--runtime-generation-descendant-ids
(etaf-runtime-current-generation runtime)
(etaf--semantic-range-item-host-ids range)))
(etaf--semantic-range-item-root-ids range)))
(unless (gethash old-id new-set)
(push old-id
(etaf-runtime-candidate-removed-semantic-ids runtime)))))
@ -4638,14 +4795,16 @@ the range is not eligible for keyed incremental rendering."
(etaf--semantic-range-artifact-key candidate)
(cons (1+ (etaf-runtime-generation runtime))
(etaf--semantic-range-effect-id range))
(etaf--semantic-range-item-host-ids candidate) item-host-ids
(etaf--semantic-range-item-root-ids candidate) item-root-ids
(etaf--semantic-range-item-identity-index candidate) item-index
(etaf--semantic-range-keyed-context-signature candidate)
(plist-get keyed-metadata :context)
(etaf--semantic-range-keyed-item-signatures candidate)
(plist-get keyed-metadata :signatures)
(etaf--semantic-range-keyed-item-id-index candidate)
(plist-get keyed-metadata :id-index)
(etaf--semantic-range-keyed-item-root-id-index candidate)
(plist-get keyed-metadata :root-id-index)
(etaf--semantic-range-keyed-item-node-span-index candidate)
(plist-get keyed-metadata :node-span-index)
(etaf--semantic-range-keyed-key-order candidate)
(plist-get keyed-metadata :keys)
(etaf--semantic-range-composition-version candidate)
@ -5440,6 +5599,7 @@ framework render-burst allocation budget when the installed Ebox supports it.
OPTIONS may provide `:viewport-width' in pixels, `:viewport-height' in lines,
and `:observer' as a one-argument flat-report sink. The observer is installed
before the first Ebox publication."
(etaf--assert-not-rendering 'mount-runtime)
(setq options (etaf--runtime-validate-mount-options options))
(let ((ebox-viewport-width (plist-get options :viewport-width))
(ebox-viewport-height (plist-get options :viewport-height)))
@ -5486,6 +5646,7 @@ before the first Ebox publication."
;;;###autoload
(defun etaf-runtime-unmount (&optional runtime)
"Unmount RUNTIME, report the operation, and detach its observer."
(etaf--assert-not-rendering 'unmount-runtime)
(let* ((runtime (etaf-runtime-require-mounted runtime))
(observer (etaf-runtime-observer runtime))
(buffer (etaf-runtime-buffer runtime)))
@ -5511,7 +5672,8 @@ before the first Ebox publication."
"Run CALLBACK after the current Component is first published."
(unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback)))
(unless etaf--current-component-instance
(unless (and etaf--current-component-instance
(eq etaf--component-phase 'setup))
(error "ETAF-on-mounted requires Component setup"))
(push callback
(etaf--component-instance-mounted-hooks
@ -5523,7 +5685,8 @@ before the first Ebox publication."
"Run CALLBACK after the current Component participates in an update."
(unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback)))
(unless etaf--current-component-instance
(unless (and etaf--current-component-instance
(eq etaf--component-phase 'setup))
(error "ETAF-on-updated requires Component setup"))
(push callback
(etaf--component-instance-updated-hooks
@ -5535,7 +5698,8 @@ before the first Ebox publication."
"Run CALLBACK when the current Component is disposed."
(unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback)))
(unless etaf--current-component-instance
(unless (and etaf--current-component-instance
(eq etaf--component-phase 'setup))
(error "ETAF-on-unmounted requires Component setup"))
(push callback
(etaf--component-instance-unmounted-hooks

387
etaf-view.el
View File

@ -29,7 +29,8 @@
(cl-defstruct (etaf--expr
(:constructor etaf--expr-create))
"Internal executable child expression."
"Internal executable interpolation or compiler-owned structural program."
(kind 'interpolation)
token
thunk
range-snapshot
@ -75,6 +76,9 @@ this list merely to make a demo convenient.")
(defconst etaf--host-marker 'etaf--host
"Value stored in the View registry for a built-in Host.")
(defconst etaf--directive-properties '(:if :else-if :else :for)
"Compiler-owned DSL properties rejected by ordinary node construction.")
(defconst etaf--ordinary-elisp-heads
'(and or not if when unless cond case pcase
let let* letrec letrec* prog prog1 prog2 progn
@ -105,6 +109,9 @@ disposing the old Runtime.")
(defvar etaf--current-component-instance nil
"Dynamic Component instance currently being evaluated.")
(defvar etaf--compiling-component-props nil
"Component prop names visible to the current DSL macro expansion.")
(defun etaf--syntax-error (format-string &rest arguments)
"Signal a View syntax error formatted from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-view-syntax-error
@ -119,25 +126,8 @@ disposing the old Runtime.")
"Return the property keyword corresponding to symbol NAME."
(intern (concat ":" (symbol-name name))))
(defun etaf--component-alias (name)
"Return the public View alias for canonical Component NAME, or nil.
Canonical names may carry the `etaf-' package prefix. The prefix is omitted
in View syntax unless doing so would collide with an Elisp function, special
form, or core Host. A collision receives a semantic `-view' alias."
(when (and (symbolp name)
(string-prefix-p "etaf-" (symbol-name name)))
(let* ((suffix (substring (symbol-name name) (length "etaf-")))
(candidate (intern suffix)))
(cond
((or (memq candidate etaf--host-names)
(special-form-p candidate)
(fboundp candidate))
(intern (concat suffix "-view")))
(t candidate)))))
(defun etaf--register-component (name spec)
"Register Component SPEC under canonical NAME and its public alias."
"Register Component SPEC under exact registry NAME."
(unless (and (symbolp name) (etaf--component-spec-p spec))
(signal 'wrong-type-argument (list 'etaf--component-spec-p spec)))
(let ((existing (gethash name etaf--view-registry)))
@ -150,34 +140,14 @@ form, or core Host. A collision receives a semantic `-view' alias."
(etaf--component-error
"Component %S is already registered" name)))
(puthash name spec etaf--view-registry)
(when-let* ((alias (etaf--component-alias name)))
(let ((existing (gethash alias etaf--view-registry)))
(when (and existing (not (eq existing spec))
(not etaf--allow-component-redefinition))
(etaf--component-error
"Component alias %S is already registered" alias)))
(puthash alias spec etaf--view-registry))
(when (fboundp 'etaf-compiler-note-registry-change)
(etaf-compiler-note-registry-change))
spec)
(defun etaf--register-core-hosts ()
"Register the core Host names and explicit prefixed spellings."
"Register the exact core Host names."
(dolist (name etaf--host-names)
(puthash name etaf--host-marker etaf--view-registry)
(puthash (intern (concat "etaf-" (symbol-name name)))
etaf--host-marker
etaf--view-registry)))
(defun etaf--canonical-host-name (name)
"Return the unprefixed renderer name for Host NAME."
(if (and (symbolp name)
(string-prefix-p "etaf-" (symbol-name name)))
(let ((short-name (intern (substring (symbol-name name) 5))))
(if (memq short-name etaf--host-names)
short-name
name))
name))
(puthash name etaf--host-marker etaf--view-registry)))
(etaf--register-core-hosts)
@ -237,12 +207,11 @@ form, or core Host. A collision receives a semantic `-view' alias."
compiled))
(defun etaf--validate-key (key)
"Validate a Host identity KEY and return it."
(unless (or (null key) (symbolp key) (stringp key)
(integerp key) (floatp key))
"Validate identity KEY and return its immutable boundary value."
(unless (and key (or (symbolp key) (stringp key) (integerp key)))
(etaf--component-error
"View keys must be immutable scalar values: %S" key))
key)
"View keys must be non-nil symbols, integers, or strings: %S" key))
(if (stringp key) (copy-sequence key) key))
(defun etaf--parse-attributes-and-children (items)
"Split structural ITEMS into `(PROPS . CHILDREN)'.
@ -273,18 +242,10 @@ the generated code."
(cons (nreverse props) (nreverse children))))
(defun etaf--parse-expr-form (items)
"Return the value form from an `expr' child with ITEMS.
`expr' intentionally has one property, `:value', and no children."
(let ((parts (etaf--parse-attributes-and-children items)))
(when (cdr parts)
(etaf--syntax-error "Expr accepts :value and no children"))
(let ((props (car parts)))
(unless (and (= (length props) 2)
(eq (car props) :value))
(etaf--syntax-error
"Expr accepts exactly one attribute: :value"))
(cadr props))))
"Return the sole ordinary Elisp form from interpolation ITEMS."
(unless (= (length items) 1)
(etaf--syntax-error "Expr accepts exactly one form: (expr FORM)"))
(car items))
(defun etaf--constant-slot-name (form)
"Return the static slot symbol represented by FORM, or signal an error."
@ -343,9 +304,231 @@ belong to the anonymous `default' slot."
"Compile an `expr' form with ITEMS into an executable View value."
(let ((token (gensym "etaf-expr-site-")))
`(etaf--expr-create
:kind 'interpolation
:token ',token
:thunk (lambda () ,(etaf--parse-expr-form items)))))
(defun etaf--structural-program-p (value)
"Return non-nil when VALUE is a compiler-owned structural program."
(and (etaf--expr-p value)
(memq (etaf--expr-kind value) '(branch keyed-list))))
(defun etaf--keyed-program-snapshot (program)
"Evaluate and validate one compiler-owned keyed-list PROGRAM snapshot."
(unless (and (etaf--expr-p program)
(eq (etaf--expr-kind program) 'keyed-list)
(functionp (etaf--expr-range-snapshot program))
(functionp (etaf--expr-range-item program)))
(etaf--component-error "Invalid keyed-list program: %S" program))
(let* ((snapshot (funcall (etaf--expr-range-snapshot program)))
(items (and (proper-list-p snapshot) (plist-get snapshot :items)))
(keys (and (proper-list-p snapshot) (plist-get snapshot :keys))))
(unless (and (proper-list-p items) (proper-list-p keys)
(= (length items) (length keys)))
(etaf--component-error "Invalid keyed-list snapshot: %S" snapshot))
(let ((seen (make-hash-table :test #'equal))
validated)
(dolist (key keys)
(setq key (etaf--validate-key key))
(when (gethash key seen)
(etaf--component-error "Duplicate keyed-list key: %S" key))
(puthash key t seen)
(push key validated))
(let ((copy (copy-sequence snapshot)))
(plist-put copy :items (copy-sequence items))
(plist-put copy :keys (nreverse validated))
copy))))
(defun etaf--keyed-program-outputs (program snapshot)
"Return PROGRAM outputs for already validated keyed SNAPSHOT."
(let ((renderer (etaf--expr-range-item program))
(context (plist-get snapshot :context)))
(mapcar (lambda (item) (funcall renderer item context))
(plist-get snapshot :items))))
(defun etaf--view-form-parts (form)
"Return parsed `(TAG PROPS CHILDREN)' for directive-capable FORM."
(unless (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot))))
(etaf--syntax-error "Directive requires a View node: %S" form))
(let ((parts (etaf--parse-attributes-and-children (cdr form))))
(list (car form) (car parts) (cdr parts))))
(defun etaf--view-directive-properties (props)
"Return directive entries present in raw PROPS."
(cl-loop for (key value) on props by #'cddr
when (memq key etaf--directive-properties)
append (list key value)))
(defun etaf--validate-directive-set (directives)
"Validate one node's raw DIRECTIVES and return them."
(let ((branch-count
(cl-count-if (lambda (key) (plist-member directives key))
'(:if :else-if :else))))
(when (> branch-count 1)
(etaf--syntax-error "A View node accepts one branch directive"))
(when (and (> branch-count 0) (plist-member directives :for))
(etaf--syntax-error "Branch directives cannot share a node with :for"))
(when (and (plist-member directives :else)
(not (eq (plist-get directives :else) t)))
(etaf--syntax-error ":else requires literal t")))
directives)
(defun etaf--view-without-directives (form)
"Return raw View FORM without compiler directive properties."
(pcase-let ((`(,tag ,props ,children) (etaf--view-form-parts form)))
(cons tag
(append
(cl-loop for (key value) on props by #'cddr
unless (memq key etaf--directive-properties)
append (list key value))
children))))
(defun etaf--compile-branch-children (first rest slot-mode)
"Compile branch FIRST and adjacent arms from REST.
Return `(COMPILED . REMAINING)' for one compiler-owned Range program."
(let ((arms nil)
(remaining rest)
(saw-else nil)
done)
(cl-labels
((add-arm
(form kind condition)
(let ((parts (etaf--view-form-parts form)))
(etaf--validate-directive-set
(etaf--view-directive-properties (nth 1 parts)))
(push (list kind condition
(etaf--compile-view-form
(etaf--view-without-directives form) slot-mode))
arms))))
(let* ((directives
(etaf--view-directive-properties
(nth 1 (etaf--view-form-parts first)))))
(add-arm first :if (plist-get directives :if)))
(while (and remaining (not done))
(let* ((candidate (car remaining))
(parts (and (consp candidate) (symbolp (car candidate))
(not (memq (car candidate) '(expr slot)))
(etaf--view-form-parts candidate)))
(directives (and parts
(etaf--view-directive-properties
(nth 1 parts)))))
(cond
((and directives (plist-member directives :else-if))
(when saw-else
(etaf--syntax-error ":else-if cannot follow :else"))
(add-arm candidate :else-if (plist-get directives :else-if))
(setq remaining (cdr remaining)))
((and directives (plist-member directives :else))
(when saw-else
(etaf--syntax-error "A branch chain accepts one :else"))
(setq saw-else t)
(add-arm candidate :else (plist-get directives :else))
(setq remaining (cdr remaining)))
(t (setq done t))))))
(let ((token (gensym "etaf-branch-site-"))
(ordered (nreverse arms)))
(cons
`(etaf--expr-create
:kind 'branch
:token ',token
:thunk
(lambda ()
(cond
,@(mapcar
(lambda (arm)
(pcase (car arm)
(:else `(t ,(nth 2 arm)))
(_ `(,(nth 1 arm) ,(nth 2 arm)))))
ordered))))
remaining))))
(defun etaf--compile-for-child (form slot-mode)
"Compile one keyed `:for' View FORM for SLOT-MODE."
(pcase-let* ((`(,_tag ,props ,_children) (etaf--view-form-parts form))
(directives
(etaf--validate-directive-set
(etaf--view-directive-properties props)))
(for-form (plist-get directives :for)))
(when (cl-some (lambda (key) (plist-member directives key))
'(:if :else-if :else))
(etaf--syntax-error "Branch directives cannot share a node with :for"))
(unless (and (proper-list-p for-form) (= (length for-form) 2)
(symbolp (car for-form))
(not (keywordp (car for-form)))
(not (memq (car for-form) '(nil t))))
(etaf--syntax-error ":for must be (ITEM ITEMS): %S" for-form))
(when (memq (car for-form) etaf--compiling-component-props)
(etaf--syntax-error ":for item %S conflicts with a Component prop"
(car for-form)))
(unless (plist-member props :key)
(etaf--syntax-error ":for requires an explicit :key"))
(let* ((item (car for-form))
(items-form (cadr for-form))
(key-form (plist-get props :key))
(compiled (etaf--compile-view-form
(etaf--view-without-directives form) slot-mode))
(token (gensym "etaf-keyed-list-site-"))
(snapshot (gensym "etaf-keyed-snapshot-"))
(item-renderer (gensym "etaf-keyed-item-")))
`(let ((,snapshot
(lambda ()
(let ((items ,items-form))
(unless (proper-list-p items)
(etaf--component-error
":for collection must be a proper list: %S" items))
(list :items (copy-sequence items)
:keys
(mapcar
(lambda (,item) (etaf--validate-key ,key-form))
items)
:context nil))))
(,item-renderer
(lambda (,item _etaf-keyed-context) ,compiled)))
(etaf--expr-create
:kind 'keyed-list
:token ',token
:thunk
(lambda ()
(let* ((program (funcall ,snapshot))
(items (plist-get program :items)))
(mapcar (lambda (,item)
(funcall ,item-renderer ,item nil))
items)))
:range-snapshot ,snapshot
:range-item ,item-renderer)))))
(defun etaf--compile-child-sequence (children slot-mode)
"Compile sibling CHILDREN with branch and keyed-list structure."
(let (compiled)
(while children
(let* ((form (car children))
(parts (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot)))
(etaf--view-form-parts form)))
(directives
(and parts
(etaf--validate-directive-set
(etaf--view-directive-properties (nth 1 parts))))))
(cond
((and directives (plist-member directives :if))
(pcase-let ((`(,value . ,remaining)
(etaf--compile-branch-children
form (cdr children) slot-mode)))
(push value compiled)
(setq children remaining)))
((and directives (plist-member directives :for))
(push (etaf--compile-for-child form slot-mode) compiled)
(setq children (cdr children)))
((and directives
(or (plist-member directives :else-if)
(plist-member directives :else)))
(etaf--syntax-error "Orphan branch arm: %S" form))
(t
(push (etaf--compile-child-form form slot-mode) compiled)
(setq children (cdr children))))))
(nreverse compiled)))
(defun etaf--compile-child-form (form &optional slot-mode)
"Compile structural child FORM into code returning a View value.
@ -358,9 +541,10 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
((and (consp form) (eq (car form) 'slot))
(etaf--compile-slot-form (cdr form) slot-mode))
((and (consp form) (symbolp (car form)))
(when (etaf--ordinary-expression-head-p (car form))
(when (and (null (gethash (car form) etaf--view-registry))
(etaf--ordinary-expression-head-p (car form)))
(etaf--syntax-error
"Elisp expression %S must be inside (expr :value ...)" (car form)))
"Elisp expression %S must be inside (expr FORM)" (car form)))
(etaf--compile-view-form form slot-mode))
((consp form)
(etaf--syntax-error "Invalid View child form: %S" form))
@ -396,10 +580,8 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
(gensym "etaf-fragment-site-"))))
`(etaf--view-call ',(car form)
(list ,@(etaf--compile-property-plist props))
(list ,@(mapcar (lambda (child)
(etaf--compile-child-form
child child-slot-mode))
children))
(list ,@(etaf--compile-child-sequence
children child-slot-mode))
,(and token `',token)))))))
;;;###autoload
@ -411,8 +593,7 @@ FORM uses one grammar for Hosts and Component calls:
(NAME :PROPERTY VALUE ... CHILD ...)
Properties must come first and children must come last. Property values are
ordinary Elisp expressions. `expr' is the only computation bridge in the
child region and accepts only `:value'."
ordinary Elisp expressions. `(expr FORM)' is text interpolation only."
(declare (indent 1) (debug (form)))
(if (fboundp 'etaf-compiler-expand-view)
(etaf-compiler-expand-view form :projection)
@ -439,6 +620,78 @@ ordinary Elisp expressions. `expr' is the only computation bridge in the
key (etaf--component-spec-name spec)))))
props))
(defun etaf--typed-view-child-p (value)
"Return non-nil when VALUE is one already validated View child."
(or (null value)
(stringp value)
(etaf--view-node-p value)
(etaf--component-call-p value)
(etaf--slot-projection-p value)))
(defun etaf--validate-component-render-result (value component-name)
"Return typed VALUE or reject COMPONENT-NAME's ambiguous render result."
(unless (etaf--typed-view-child-p value)
(etaf--component-error
"Component %S must render nil, a string, or one typed View; got %S"
component-name value))
value)
(defun etaf--validate-code-children (children context)
"Return a detached CHILDREN spine after typed validation for CONTEXT."
(unless (proper-list-p children)
(etaf--component-error "%s children must be a proper list: %S"
context children))
(dolist (child children)
(unless (etaf--typed-view-child-p child)
(etaf--component-error
"%s child must be nil, string, or typed View: %S" context child)))
(copy-sequence children))
(defun etaf--validate-code-slots (slots)
"Return typed named SLOTS as internal slot inputs."
(unless (proper-list-p slots)
(etaf--component-error "Named slots must be a proper alist: %S" slots))
(let (seen result)
(dolist (entry slots (nreverse result))
(unless (and (consp entry)
(symbolp (car entry))
(not (keywordp (car entry)))
(not (memq (car entry) '(nil t))))
(etaf--component-error "Invalid named slot entry: %S" entry))
(when (memq (car entry) seen)
(etaf--component-error "Duplicate Component slot %S" (car entry)))
(push (car entry) seen)
(push (etaf--slot-input-create
:name (car entry)
:children (etaf--validate-code-children
(cdr entry) (format "Slot %S" (car entry))))
result))))
;;;###autoload
(defun etaf-node (tag props children &optional named-slots)
"Construct one typed View node from evaluated ordinary Elisp values.
TAG is an exact Host or Component registry symbol. PROPS is a keyword plist,
CHILDREN is a list of typed View children, and NAMED-SLOTS is a Component-only
alist from stable slot symbols to typed child lists."
(unless (symbolp tag)
(etaf--component-error "Node tag must be a symbol: %S" tag))
(setq props (etaf--validate-property-plist props))
(dolist (directive etaf--directive-properties)
(when (plist-member props directive)
(etaf--component-error
"Code node %S rejects DSL directive %S" tag directive)))
(when (plist-member props :key)
(setq props
(plist-put props :key
(etaf--validate-key (plist-get props :key)))))
(let* ((entry (gethash tag etaf--view-registry))
(children (etaf--validate-code-children children
(format "Node %S" tag)))
(slot-inputs (etaf--validate-code-slots named-slots)))
(when (and slot-inputs (eq entry etaf--host-marker))
(etaf--component-error "Host %S does not accept named slots" tag))
(etaf--view-call tag props (append children slot-inputs))))
(defun etaf--text-view-from-string (value)
"Return one normalized Text View containing string VALUE."
(etaf--view-node-create :name 'text :props nil :children (list value)))
@ -462,7 +715,7 @@ ordinary Elisp expressions. `expr' is the only computation bridge in the
(setq props (etaf--validate-property-plist props))
(let* ((entry (gethash name etaf--view-registry))
(host-name (and (eq entry etaf--host-marker)
(etaf--canonical-host-name name)))
name))
(children
(if (eq host-name 'text)
children

100
tests/etaf-compiler-tests.el
View File

@ -5,10 +5,6 @@
(require 'ert)
(require 'etaf)
(defmacro etaf-compiler-test--legacy-view (form)
"Construct FORM through the pre-compiler View expansion for comparison."
(etaf--compile-view-form form :projection))
(defun etaf-compiler-test--canonical (value)
"Return VALUE as comparable View data, resolving lazy holes once."
(cond
@ -27,42 +23,31 @@
((null value) nil)
(t value)))
(defun etaf-compiler-test--interpreted (color text)
"Return an interpreted fixture using COLOR and TEXT."
(etaf-compiler-test--legacy-view
(column :color color
(column :padding '(1 2)
(text "static"))
(text (expr :value text)))))
(defun etaf-compiler-test--lowered (color text)
"Return an automatically lowered fixture using COLOR and TEXT."
(etaf-view
(column :color color
(column :padding '(1 2)
(text "static"))
(text (expr :value text)))))
(text (expr text)))))
(defun etaf-compiler-test--fallback-view ()
"Return a View containing unsupported slot grammar."
(defun etaf-compiler-test--slot-view ()
"Return a blueprint-backed View containing a slot projection."
(etaf-view
(column (slot (text "fallback")))))
(defun etaf-compiler-test--fallback-reference ()
"Return the interpreted reference for `etaf-compiler-test--fallback-view'."
(etaf-compiler-test--legacy-view
(column (slot (text "fallback")))))
(ert-deftest etaf-automatic-view-fallback-is-exact ()
"An unsupported slot keeps the existing View semantics."
(let ((before (plist-get (etaf-compiler-statistics) :fallbacks)))
(should
(equal (etaf-compiler-test--canonical
(etaf-compiler-test--fallback-view))
(etaf-compiler-test--canonical
(etaf-compiler-test--fallback-reference))))
(should (= (1+ before)
(plist-get (etaf-compiler-statistics) :fallbacks)))))
(ert-deftest etaf-automatic-view-slot-uses-current-blueprint-abi ()
"Slot projection is a `/2' block and never takes a compatibility path."
(let* ((before (plist-get (etaf-compiler-statistics) :instantiations))
(view (etaf-compiler-test--slot-view))
(after (etaf-compiler-statistics))
(root (plist-get etaf-compiler--last-blueprint :root)))
(should (etaf--slot-projection-p
(car (etaf--view-node-children view))))
(should (eq 'slot
(plist-get (car (plist-get root :children)) :kind)))
(should (= (1+ before) (plist-get after :instantiations)))
(should-not (plist-member after :fallbacks))))
(defun etaf-compiler-test--lowered-supported (color)
"Return a supported automatically lowered fixture using COLOR."
@ -73,22 +58,18 @@
(text "static-b"))
(text :color "blue" "tail"))))
(defun etaf-compiler-test--interpreted-supported (color)
"Return the matching interpreted fixture using COLOR."
(etaf-compiler-test--legacy-view
(column :color color
(column :padding '(1 2)
(text "static-a")
(text "static-b"))
(text :color "blue" "tail"))))
(ert-deftest etaf-automatic-view-supported-output-is-exact ()
"A supported blueprint produces the same normalized View data."
"A blueprint produces the exact normalized typed View data."
(should
(equal (etaf-compiler-test--canonical
(etaf-compiler-test--lowered-supported "green"))
(etaf-compiler-test--canonical
(etaf-compiler-test--interpreted-supported "green")))))
'(:host column :props (:color "green")
:children
((:host column :props (:padding (1 2))
:children
((:host text :props nil :children ("static-a"))
(:host text :props nil :children ("static-b"))))
(:host text :props (:color "blue") :children ("tail")))))))
(ert-deftest etaf-automatic-view-reuses-static-subtrees ()
"Repeated instantiation reuses a static child while rebuilding its root."
@ -111,14 +92,7 @@
(cl-incf calls)
(apply original arguments))))
(etaf-compiler-test--lowered-supported "next"))
(should (= calls 1))
(setq calls 0)
(cl-letf (((symbol-function 'etaf--view-call)
(lambda (&rest arguments)
(cl-incf calls)
(apply original arguments))))
(etaf-compiler-test--interpreted-supported "next"))
(should (> calls 1))))
(should (= calls 1))))
(ert-deftest etaf-automatic-view-exposes-blueprint-coverage ()
"The compiler reports static nodes, dynamic paths, and holes."
@ -139,7 +113,7 @@
"Expr becomes one dynamic child program without forcing root fallback."
(pcase-let* ((`(,blueprint . ,programs)
(etaf-compiler--compile
'(column (text (expr :value value)))))
'(column (text (expr value)))))
(root (plist-get blueprint :root))
(text-block (car (plist-get root :children)))
(expr-block (car (plist-get text-block :children))))
@ -147,5 +121,29 @@
(should-not (plist-get root :static-p))
(should (= (length programs) 1))))
(ert-deftest etaf-automatic-view-directives-are-blueprint-blocks ()
"Branch and keyed list topology are represented inside the `/2' blueprint."
(pcase-let* ((`(,blueprint . ,programs)
(etaf-compiler--compile
'(column
(text :if selected "selected")
(text :else t "empty")
(row :for (item items) :key (car item)
(text (expr (cdr item)))))))
(children (plist-get (plist-get blueprint :root) :children)))
(should (equal '(branch keyed-list)
(mapcar (lambda (block) (plist-get block :kind)) children)))
(should (= 2 (length programs)))
(should (= 2 (plist-get blueprint :hole-count)))))
(ert-deftest etaf-automatic-view-rejects-stale-blueprint-abi ()
"A stale View IR requests a clean rebuild instead of compatibility."
(let ((blueprint
(list :kind 'etaf/view-blueprint
:abi "etaf-view-blueprint/1"
:id "stale" :root nil :hole-count 0)))
(should-error (etaf-compiler-instantiate blueprint [])
:type 'error)))
(provide 'etaf-compiler-tests)
;;; etaf-compiler-tests.el ends here

569
tests/etaf-component-frontends-tests.el Normal file
View File

@ -0,0 +1,569 @@
;;; etaf-component-frontends-tests.el --- Component frontend contract -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'etaf)
(defvar etaf-test-g6b-dsl-setup-count 0)
(defvar etaf-test-g6b-code-setup-count 0)
(defvar etaf-test-g6b-lifecycle nil)
(etaf-define-component etaf-test-g6b-dsl-counter (&key initial)
:setup
(progn
(cl-incf etaf-test-g6b-dsl-setup-count)
(etaf-ref (or initial 0)))
:view
(column :background-color "#102030" :padding-inline 1
(text :font-weight 'bold
(expr (format "Count %d" (etaf-value (etaf-state)))))
(box :ref 'g6b-dsl-increment
:on-press
(let ((count (etaf-state)))
(lambda ()
(setf (etaf-value count) (1+ (etaf-value count)))))
"Increment")))
(etaf-define-component etaf-test-g6b-code-counter (&key initial)
:setup
(progn
(cl-incf etaf-test-g6b-code-setup-count)
(etaf-ref (or initial 0)))
:render
(let ((count (etaf-state)))
(etaf-node
'column (list :background-color "#102030" :padding-inline 1)
(list
(etaf-node 'text (list :font-weight 'bold)
(list (format "Count %d" (etaf-value count))))
(etaf-node
'box
(list :ref 'g6b-code-increment
:on-press
(lambda ()
(setf (etaf-value count) (1+ (etaf-value count)))))
(list "Increment"))))))
(etaf-define-component etaf-test-g6b-nil-state ()
:setup nil
:view (text (expr (if (null (etaf-state)) "nil-state" "bad-state"))))
(etaf-define-component etaf-test-g6b-directives (&key selected items)
:view
(column
(text :if selected :key 'selected (expr selected))
(text :else t :key 'empty "No selection")
(row :for (item items) :key (car item)
(text (expr (cdr item))))))
(etaf-define-component etaf-test-g6b-pair (&key item)
:view
(fragment
(text (expr (format "%s-1" (cdr item))))
(text (expr (format "%s-2" (cdr item))))))
(etaf-define-component etaf-test-g6b-component-loop (&key items)
:view
(column
(etaf-test-g6b-pair :for (item items) :key (car item) :item item)))
(etaf-define-component etaf-test-g6b-key-boundary (&key value)
:setup
(list :framework-key (etaf-current-prop 'key) :initial value)
:view
(text
(expr
(format "%s/%s"
(plist-get (etaf-state) :initial)
(or (plist-get (etaf-state) :framework-key) "no-key")))))
(etaf-define-component etaf-test-g6b-invalid-list-result ()
:render
(list (etaf-node 'text nil (list "ambiguous"))))
(etaf-define-component etaf-test-g6b-rollback (&key fail)
:setup (etaf-ref 7)
:render
(let ((state (etaf-state)))
(when fail
(setf (etaf-value state) 99))
(etaf-node 'text nil (list (format "Stable %d" (etaf-value state))))))
(etaf-define-component etaf-test-g6b-lifecycle (&key label)
:setup
(progn
(etaf-on-mounted
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(mounted)))))
(etaf-on-updated
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(updated)))))
(etaf-on-unmounted
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(unmounted)))))
(etaf-on-scope-dispose
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(cleanup)))))
nil)
:view (text (expr label)))
(etaf-define-component etaf-test-g6b-provider ()
:setup
(progn
(etaf-provide 'g6b-message "Context")
(etaf-theme-provide '(:color "#34D399"))
nil)
:view (column (slot)))
(etaf-define-component etaf-test-g6b-context-action (&key count on-press)
:render
(etaf-node
'box
(list :class '(g6b-context-action)
:ref 'g6b-context-action
:use (etaf-focusable)
:on-press on-press)
(list (format "%s %d" (etaf-inject 'g6b-message "missing") count)))
:styles
(styles
(".g6b-context-action" :background-color "#1F2937")))
(etaf-define-component etaf-test-g6b-dsl-panel ()
:view
(column :background-color "#203040" :padding-inline 1
(row :class 'header (slot :name 'header))
(box (slot))
(row :class 'actions (slot :name 'actions))))
(etaf-define-component etaf-test-g6b-code-panel ()
:render
(etaf-node
'column (list :background-color "#203040" :padding-inline 1)
(list
(etaf-node 'row (list :class 'header)
(etaf-current-slot 'header))
(etaf-node 'box nil (etaf-current-slot 'default))
(etaf-node 'row (list :class 'actions)
(etaf-current-slot 'actions)))))
(defun etaf-test-g6b-dsl-counter (&rest _arguments)
"Ordinary Elisp function colliding with a Component registry name."
'ordinary-function)
(defun etaf-test-g6b--text (buffer)
"Return BUFFER text without properties."
(with-current-buffer buffer
(substring-no-properties (buffer-string))))
(defun etaf-test-g6b--face-at (buffer regexp)
"Return BUFFER face at the first REGEXP match."
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(re-search-forward regexp)
(get-text-property (match-beginning 0) 'face))))
(defun etaf-test-g6b--face-value (face property)
"Return PROPERTY from anonymous FACE values."
(cond
((and (listp face) (keywordp (car-safe face)))
(plist-get face property))
((listp face)
(cl-loop for entry in face
when (and (listp entry) (keywordp (car-safe entry))
(plist-member entry property))
return (plist-get entry property)))))
(ert-deftest etaf-component-frontends-definition-boundary-is-strict ()
"Definitions choose one frontend and keep exact registry names."
(should (etaf--component-spec-p
(gethash 'etaf-test-g6b-dsl-counter etaf--view-registry)))
(should-not (gethash 'test-g6b-dsl-counter etaf--view-registry))
(should (eq 'ordinary-function (etaf-test-g6b-dsl-counter)))
(dolist
(definition
'((etaf-define-component invalid-both ()
:view (box) :render (etaf-node 'box nil nil))
(etaf-define-component invalid-neither () :setup nil)
(etaf-define-component invalid-reserved (&key key) :view (box))
(etaf-define-component invalid-setup-view ()
:setup (etaf-node 'box nil nil) :view (box))
(etaf-define-component invalid-render-dsl ()
:render (etaf-view (box)))))
(should-error (macroexpand definition)
:type 'etaf-component-definition-error)))
(ert-deftest etaf-node-validates-code-mode-structure ()
"Code nodes accept typed values and reject DSL or raw-list ambiguity."
(should (etaf--view-node-p
(etaf-node 'box (list :padding 1) (list "A"))))
(should (etaf--component-call-p
(etaf-node 'etaf-test-g6b-dsl-counter
(list :initial 1) nil)))
(should-error (etaf-node 'box (list :if t) nil)
:type 'etaf-component-call-error)
(should-error (etaf-node 'box nil '((text "raw")))
:type 'etaf-component-call-error)
(should-error (etaf-node 'box nil nil '((header . ("H"))))
:type 'etaf-component-call-error)
(should-error (etaf-node 'box (list :key nil) nil)
:type 'etaf-component-call-error))
(ert-deftest etaf-component-directives-validate-branch-and-loop-grammar ()
"DSL directives reject ambiguous structure during macro expansion."
(dolist
(form
'((etaf-view (column (text :else t "orphan")))
(etaf-view
(column (text :if t :for (item '(1)) :key item "bad")))
(etaf-view (column (text :for (item '(1)) "missing key")))
(etaf-view
(column (text :if nil "a") (text :else maybe "b")))))
(should-error (macroexpand form) :type 'etaf-view-syntax-error)))
(ert-deftest etaf-component-directives-render-and-retain-keyed-identity ()
"Branch changes and keyed reorder publish locally with stable item ids."
(let ((buffer " *etaf-g6b-directives*")
(selected (etaf-ref nil))
(items (etaf-ref '((a . "A") (b . "B")))))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-directives
:selected (etaf-value selected)
:items (etaf-value items)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(range
(cl-loop for _identity being the hash-keys of
(etaf-generation-identity-index generation)
using (hash-values semantic-id)
for semantic = (etaf--pvec-get
(etaf-generation-semantic-nodes
generation)
semantic-id)
when (and (etaf--semantic-range-p semantic)
(etaf--semantic-range-keyed-key-order
semantic))
return semantic))
(a-roots
(gethash
'a
(etaf--semantic-range-keyed-item-root-id-index range)))
(b-roots
(gethash
'b
(etaf--semantic-range-keyed-item-root-id-index range))))
(should (string-match-p "No selection"
(etaf-test-g6b--text buffer)))
(should (string-match-p "A[[:space:]]+B"
(etaf-test-g6b--text buffer)))
(setf (etaf-value selected) "Selected")
(setf (etaf-value items) '((b . "B2") (a . "A")))
(should (string-match-p "Selected"
(etaf-test-g6b--text buffer)))
(should (string-match-p "B2[[:space:]]+A"
(etaf-test-g6b--text buffer)))
(let* ((generation (etaf-runtime-current-generation runtime))
(next (etaf--pvec-get
(etaf-generation-semantic-nodes generation)
(etaf--semantic-range-semantic-id range))))
(should
(equal
a-roots
(gethash
'a
(etaf--semantic-range-keyed-item-root-id-index next))))
(should
(equal
b-roots
(gethash
'b
(etaf--semantic-range-keyed-item-root-id-index next)))))
(let ((generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer (buffer-string))))
(should-error
(setf (etaf-value items) '((a . "A") (a . "duplicate")))
:type 'etaf-component-call-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer (buffer-string)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-keyed-loop-owns-transparent-component-spans ()
"A keyed item may be a transparent multi-root Component without a fake Box."
(let ((buffer " *etaf-g6b-component-spans*")
(items (etaf-ref '((a . "A") (b . "B")))))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-component-loop :items (etaf-value items)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(range
(cl-loop for _identity being the hash-keys of
(etaf-generation-identity-index generation)
using (hash-values semantic-id)
for semantic =
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
semantic-id)
when (and (etaf--semantic-range-p semantic)
(equal
'(a b)
(etaf--semantic-range-keyed-key-order
semantic)))
return semantic))
(root-index
(etaf--semantic-range-keyed-item-root-id-index range))
(a-roots (copy-sequence (gethash 'a root-index)))
(b-roots (copy-sequence (gethash 'b root-index))))
(should (string-match-p
"A-1[[:space:]]+A-2[[:space:]]+B-1[[:space:]]+B-2"
(etaf-test-g6b--text buffer)))
(should (= 1 (length a-roots)))
(should (= 1 (length b-roots)))
(should
(etaf--semantic-component-p
(etaf--pvec-get
(etaf-generation-semantic-nodes generation) (car a-roots))))
(setf (etaf-value items) '((b . "B2") (a . "A")))
(setq generation (etaf-runtime-current-generation runtime)
range
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
(etaf--semantic-range-semantic-id range))
root-index
(etaf--semantic-range-keyed-item-root-id-index range))
(should (string-match-p
"B2-1[[:space:]]+B2-2[[:space:]]+A-1[[:space:]]+A-2"
(etaf-test-g6b--text buffer)))
(should (equal a-roots (gethash 'a root-index)))
(should (equal b-roots (gethash 'b root-index)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-frontends-project-default-and-named-slots ()
"DSL and code Components preserve caller-owned slot order and styling."
(let ((dsl-buffer " *etaf-g6b-dsl-slots*")
(code-buffer " *etaf-g6b-code-slots*"))
(unwind-protect
(progn
(etaf-mount
dsl-buffer
(etaf-view
(etaf-test-g6b-dsl-panel
(slot :name 'header (text :font-weight 'bold "Header"))
(slot :name 'actions "Actions")
"Body")))
(etaf-mount
code-buffer
(etaf-node
'etaf-test-g6b-code-panel nil (list "Body")
(list
(cons 'header
(list (etaf-node 'text (list :font-weight 'bold)
(list "Header"))))
(cons 'actions (list "Actions")))))
(dolist (buffer (list dsl-buffer code-buffer))
(let ((text (etaf-test-g6b--text buffer)))
(should (string-match-p
"Header[[:space:]]+Body[[:space:]]+Actions" text)))
(should (eq 'bold
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Header")
:weight)))))
(dolist (buffer-name (list dsl-buffer code-buffer))
(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-component-frontends-render-state-layout-style-and-events ()
"DSL and code Components mount equivalent stateful interactive surfaces."
(setq etaf-test-g6b-dsl-setup-count 0
etaf-test-g6b-code-setup-count 0)
(let ((dsl-buffer " *etaf-g6b-dsl*")
(code-buffer " *etaf-g6b-code*"))
(unwind-protect
(progn
(etaf-mount dsl-buffer
(etaf-view
(etaf-test-g6b-dsl-counter :initial 1)))
(etaf-mount code-buffer
(etaf-node 'etaf-test-g6b-code-counter
(list :initial 1) nil))
(should (= 1 etaf-test-g6b-dsl-setup-count))
(should (= 1 etaf-test-g6b-code-setup-count))
(dolist (buffer (list dsl-buffer code-buffer))
(let ((text (etaf-test-g6b--text buffer)))
(should (string-match-p "Count 1" text))
(should (string-match-p "Increment" text))
(should (= 2 (length (split-string text "\n" t)))))
(should (eq 'bold
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Count 1")
:weight))))
(let* ((dsl-runtime (etaf-runtime-for-buffer dsl-buffer))
(code-runtime (etaf-runtime-for-buffer code-buffer))
(dsl-instance
(car (hash-table-values (etaf-runtime-instances dsl-runtime))))
(code-instance
(car (hash-table-values (etaf-runtime-instances code-runtime)))))
(etaf-dispatch-event dsl-runtime 'g6b-dsl-increment 'press)
(etaf-dispatch-event code-runtime 'g6b-code-increment 'press)
(should (string-match-p "Count 2"
(etaf-test-g6b--text dsl-buffer)))
(should (string-match-p "Count 2"
(etaf-test-g6b--text code-buffer)))
(should (= 1 etaf-test-g6b-dsl-setup-count))
(should (= 1 etaf-test-g6b-code-setup-count))
(should (eq dsl-instance
(car (hash-table-values
(etaf-runtime-instances dsl-runtime)))))
(should (eq code-instance
(car (hash-table-values
(etaf-runtime-instances code-runtime)))))))
(dolist (buffer-name (list dsl-buffer code-buffer))
(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-component-state-distinguishes-nil-from-no-setup ()
"A completed setup may return nil without becoming setup absence."
(let ((buffer " *etaf-g6b-nil-state*"))
(unwind-protect
(progn
(etaf-mount buffer (etaf-view (etaf-test-g6b-nil-state)))
(should (equal "nil-state" (etaf-test-g6b--text buffer))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live))))
(should-error (etaf-state) :type 'etaf-component-definition-error))
(ert-deftest etaf-component-key-is-framework-owned-and-render-result-is-typed ()
"Identity metadata stays outside business props and node lists stay invalid."
(let ((buffer " *etaf-g6b-key-boundary*")
(invalid-buffer " *etaf-g6b-invalid-result*"))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-test-g6b-key-boundary :key 'stable :value "Business")))
(should (string-match-p "Business/no-key"
(etaf-test-g6b--text buffer)))
(should-error
(etaf-mount
invalid-buffer
(etaf-view (etaf-test-g6b-invalid-list-result)))
:type 'etaf-component-call-error))
(dolist (buffer-name (list buffer invalid-buffer))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer-name))) (kill-buffer live))))))
(ert-deftest etaf-component-render-side-effect-rolls-back-completely ()
"A detectable render mutation preserves the published generation and state."
(let ((buffer " *etaf-g6b-render-rollback*")
(fail (etaf-ref nil)))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-rollback :fail (etaf-value fail)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(published (with-current-buffer buffer (buffer-string)))
(instance
(car (hash-table-values (etaf-runtime-instances runtime))))
(state (etaf--component-instance-state instance)))
(should-error (setf (etaf-value fail) t)
:type 'etaf-render-write-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
published (with-current-buffer buffer (buffer-string))))
(should (= 7 (etaf-value state)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-lifecycle-and-scope-cleanup-are-ordered ()
"Mount, update, removal, and Scope cleanup each run once in order."
(let ((buffer " *etaf-g6b-lifecycle*")
(label (etaf-ref "A")))
(setq etaf-test-g6b-lifecycle nil)
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-lifecycle :label (etaf-value label)))))
(should (equal '(mounted) etaf-test-g6b-lifecycle))
(setf (etaf-value label) "B")
(should (equal '(mounted updated) etaf-test-g6b-lifecycle))
(should (string-match-p "B" (etaf-test-g6b--text buffer)))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (equal '(mounted updated unmounted cleanup)
etaf-test-g6b-lifecycle)))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-frontends-compose-context-theme-style-and-behavior ()
"A DSL provider and code Component share Context, Theme, style, and events."
(let ((buffer " *etaf-g6b-composition*")
(count (etaf-ref 0)))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-provider
(etaf-test-g6b-context-action
:count (etaf-value count)
:on-press
(let ((source count))
(lambda ()
(setf (etaf-value source)
(1+ (etaf-value source))))))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(face (etaf-test-g6b--face-at buffer "Context 0"))
(props
(etaf-runtime-host-props-for
runtime 'g6b-context-action)))
(should (equal "#34D399"
(etaf-test-g6b--face-value face :foreground)))
(should (equal "#1F2937"
(etaf-test-g6b--face-value face :background)))
(should (= 0 (plist-get props :tab-index)))
(etaf-dispatch-event runtime 'g6b-context-action 'press)
(should (string-match-p "Context 1"
(etaf-test-g6b--text buffer)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(provide 'etaf-component-frontends-tests)
;;; etaf-component-frontends-tests.el ends here