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) (defun etaf-action-register (name function)
"Register FUNCTION as named Action NAME and return NAME." "Register FUNCTION as named Action NAME and return NAME."
(etaf--assert-not-rendering 'register-action)
(unless (and (symbolp name) (not (keywordp name)) (functionp function)) (unless (and (symbolp name) (not (keywordp name)) (functionp function))
(signal 'etaf-action-error (signal 'etaf-action-error
(list (format "Invalid Action registration: %S" name)))) (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 An explicit Runtime may be supplied as the first argument: `(etaf-dispatch
RUNTIME ACTION ...)'. Action functions receive Runtime first." RUNTIME ACTION ...)'. Action functions receive Runtime first."
(etaf--assert-not-rendering 'dispatch-action)
(let* ((explicit-runtime (etaf-runtime-p action)) (let* ((explicit-runtime (etaf-runtime-p action))
(runtime (if explicit-runtime (runtime (if explicit-runtime
action action
@ -94,6 +96,7 @@ RUNTIME ACTION ...)'. Action functions receive Runtime first."
;;;###autoload ;;;###autoload
(defun etaf-action-undefine (name) (defun etaf-action-undefine (name)
"Remove named Action NAME and return NAME." "Remove named Action NAME and return NAME."
(etaf--assert-not-rendering 'undefine-action)
(remhash name etaf--action-registry) (remhash name etaf--action-registry)
name) name)

252
etaf-compiler.el
View File

@ -15,12 +15,11 @@
(require 'cl-lib) (require 'cl-lib)
(require 'etaf-view) (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--static-cache (make-hash-table :test #'equal))
(defvar etaf-compiler--registry-epoch 0) (defvar etaf-compiler--registry-epoch 0)
(defvar etaf-compiler--instantiate-count 0) (defvar etaf-compiler--instantiate-count 0)
(defvar etaf-compiler--fallback-count 0)
(defvar etaf-compiler--last-blueprint nil) (defvar etaf-compiler--last-blueprint nil)
(defun etaf-compiler-note-registry-change () (defun etaf-compiler-note-registry-change ()
@ -37,7 +36,6 @@
"Return a read-only snapshot of compiler runtime statistics." "Return a read-only snapshot of compiler runtime statistics."
(list :abi etaf-compiler-blueprint-abi (list :abi etaf-compiler-blueprint-abi
:instantiations etaf-compiler--instantiate-count :instantiations etaf-compiler--instantiate-count
:fallbacks etaf-compiler--fallback-count
:static-cache-entries (hash-table-count etaf-compiler--static-cache) :static-cache-entries (hash-table-count etaf-compiler--static-cache)
:last-blueprint :last-blueprint
(and etaf-compiler--last-blueprint (and etaf-compiler--last-blueprint
@ -68,29 +66,93 @@
(cons (list :kind 'hole :index index) (cons (list :kind 'hole :index index)
(append programs (list `(lambda () ,form))))))) (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." "Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
(cond (cond
((or (null form) (stringp form)) ((or (null form) (stringp form))
(list (list :kind 'literal :value form :path path :static-p t) programs)) (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) ((eq (car form) 'expr)
(let ((index (length programs))) (let ((index (length programs)))
(list (list :kind 'expr :path path :hole index :static-p nil) (list (list :kind 'expr :path path :hole index :static-p nil)
(append programs (append programs
(list `(lambda () ,(etaf--parse-expr-form (cdr form)))))))) (list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
((eq (car form) 'slot) nil) ((eq (car form) 'slot)
((etaf--ordinary-expression-head-p (car form)) nil) (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 (t
(let* ((parts (etaf--parse-attributes-and-children (cdr form))) (let* ((parts (etaf--parse-attributes-and-children (cdr form)))
(props (car parts)) (props (car parts))
(children (cdr 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-props nil)
(compiled-children nil)
(all-static t) (all-static t)
(tail props) (tail props))
(child-index 0)
result)
(while tail (while tail
(let* ((key (pop tail)) (let* ((key (pop tail))
(value (pop tail)) (value (pop tail))
@ -101,22 +163,15 @@
(setq all-static nil)) (setq all-static nil))
(setq compiled-props (setq compiled-props
(append compiled-props (list key descriptor))))) (append compiled-props (list key descriptor)))))
(while (and children (not (eq result 'unsupported))) (pcase-let* ((`(,compiled-children ,next-programs)
(let ((compiled (etaf-compiler--compile-children
(etaf-compiler--compile-block children path programs child-slot-mode)))
(pop children) (append path (list child-index)) programs))) (dolist (block compiled-children)
(if (not compiled) (unless (plist-get block :static-p) (setq all-static nil)))
(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)
(list (list :kind 'node :name (car form) :path path (list (list :kind 'node :name (car form) :path path
:props compiled-props :children compiled-children :props compiled-props :children compiled-children
:static-p all-static) :static-p all-static)
programs)))))) next-programs))))))
(defun etaf-compiler--block-counts (block) (defun etaf-compiler--block-counts (block)
"Return `(STATIC . DYNAMIC)' node counts below BLOCK." "Return `(STATIC . DYNAMIC)' node counts below BLOCK."
@ -131,15 +186,15 @@
(cl-incf dynamic child-dynamic))) (cl-incf dynamic child-dynamic)))
(cons static dynamic)))) (cons static dynamic))))
(defun etaf-compiler--beneficial-blueprint-p (blueprint) (defun etaf-compiler--compile (form &optional slot-mode)
"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)
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil." "Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
(when-let* ((compiled (etaf-compiler--compile-block form '(0) nil))) (pcase-let* ((`(,roots ,programs)
(let* ((root (car compiled)) (etaf-compiler--compile-children
(programs (cadr compiled)) (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))) (id (secure-hash 'sha256 (prin1-to-string form)))
(counts (etaf-compiler--block-counts root))) (counts (etaf-compiler--block-counts root)))
(cons (list :kind 'etaf/view-blueprint (cons (list :kind 'etaf/view-blueprint
@ -150,6 +205,100 @@
:hole-count (length programs)) :hole-count (length programs))
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) (defun etaf-compiler--materialize (blueprint block programs)
"Materialize BLOCK from BLUEPRINT using PROGRAMS." "Materialize BLOCK from BLUEPRINT using PROGRAMS."
(let* ((static-p (plist-get block :static-p)) (let* ((static-p (plist-get block :static-p))
@ -171,6 +320,22 @@
(plist-get blueprint :id) (plist-get blueprint :id)
(plist-get block :path)) (plist-get block :path))
:thunk (aref programs (plist-get block :hole)))) :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 ('node
(let ((props nil)) (let ((props nil))
(cl-loop for (key descriptor) on (plist-get block :props) (cl-loop for (key descriptor) on (plist-get block :props)
@ -205,12 +370,9 @@
;;;###autoload ;;;###autoload
(defun etaf-compiler-instantiate (blueprint programs) (defun etaf-compiler-instantiate (blueprint programs)
"Instantiate automatically lowered View BLUEPRINT with dynamic PROGRAMS." "Instantiate automatically lowered View BLUEPRINT with dynamic PROGRAMS."
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint) (unless (and (vectorp programs)
(equal (plist-get blueprint :abi) (etaf-compiler--valid-blueprint-p
etaf-compiler-blueprint-abi) blueprint (length programs)))
(stringp (plist-get blueprint :id))
(vectorp programs)
(= (length programs) (plist-get blueprint :hole-count)))
(error "Invalid or incompatible ETAF View blueprint")) (error "Invalid or incompatible ETAF View blueprint"))
(cl-incf etaf-compiler--instantiate-count) (cl-incf etaf-compiler--instantiate-count)
(setq etaf-compiler--last-blueprint blueprint) (setq etaf-compiler--last-blueprint blueprint)
@ -219,14 +381,12 @@
(defun etaf-compiler-expand-view (form &optional slot-mode) (defun etaf-compiler-expand-view (form &optional slot-mode)
"Return compiler expansion for View FORM. "Return compiler expansion for View FORM.
SLOT-MODE is forwarded to the legacy compiler." SLOT-MODE distinguishes Component projections from call-site slot inputs."
(let* ((compiled (etaf-compiler--compile form)) (let* ((compiled (etaf-compiler--compile
(blueprint (car compiled)) form (or slot-mode :projection)))
(legacy (etaf--compile-view-form form (or slot-mode :projection)))) (blueprint (car compiled)))
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint)) `(etaf-compiler-instantiate
`(etaf-compiler-instantiate ',blueprint (vector ,@(cdr compiled)))))
',blueprint (vector ,@(cdr compiled)))
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy))))
(provide 'etaf-compiler) (provide 'etaf-compiler)
;;; etaf-compiler.el ends here ;;; etaf-compiler.el ends here

122
etaf-component.el
View File

@ -4,15 +4,15 @@
;;; Commentary: ;;; Commentary:
;; Components have one public definition boundary. A stateless Component ;; Components have one public definition boundary with two strict authoring
;; declares `:view'; a stateful Component declares `:setup' which runs once ;; frontends: compiled `:view' DSL and ordinary Elisp `:render'. Optional
;; per retained instance and returns a render function. Both forms produce ;; `:setup' runs once and returns opaque state read through `etaf-state'.
;; the same normalized View tree and share props, slots, styles, and Context.
;;; Code: ;;; Code:
(require 'cl-lib) (require 'cl-lib)
(require 'etaf-view) (require 'etaf-view)
(require 'etaf-compiler)
(define-error 'etaf-component-definition-error (define-error 'etaf-component-definition-error
"Invalid ETAF Component definition" "Invalid ETAF Component definition"
@ -25,6 +25,22 @@
(defvar etaf--raw-slot-read-p nil (defvar etaf--raw-slot-read-p nil
"Set while a Component render uses public raw slot accessors.") "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) (defun etaf--component-definition-error (format-string &rest arguments)
"Signal a Component definition error from FORMAT-STRING and ARGUMENTS." "Signal a Component definition error from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-component-definition-error (signal 'etaf-component-definition-error
@ -51,6 +67,9 @@
(when (memq entry prop-names) (when (memq entry prop-names)
(etaf--component-definition-error (etaf--component-definition-error
"Duplicate Component prop: %S" entry)) "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)) (push entry prop-names))
(nreverse 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 (plist-get etaf--current-component-props
(etaf--component-prop-key name))) (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 ;;;###autoload
(defun etaf-component-set-styles (name styles) (defun etaf-component-set-styles (name styles)
"Replace the static style form for Component NAME with 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 () (defun etaf-current-slots ()
"Return the current Component's normalized slot alist." "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) (setq etaf--raw-slot-read-p t)
(mapcar (lambda (entry) (mapcar (lambda (entry)
(cons (car entry) (cons (car entry)
@ -120,6 +159,9 @@ does not depend on ETAF's private registry flag."
(defun etaf-current-slot (name &optional fallback) (defun etaf-current-slot (name &optional fallback)
"Return the child list for slot NAME, or FALLBACK when it is absent." "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) (setq etaf--raw-slot-read-p t)
(let ((entry (assq name etaf--current-component-slots))) (let ((entry (assq name etaf--current-component-slots)))
(if entry (if entry
@ -158,34 +200,48 @@ does not depend on ETAF's private registry flag."
name key))))))) name key)))))))
form) 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 ;;;###autoload
(defmacro etaf-define-component (name arguments &rest clauses) (defmacro etaf-define-component (name arguments &rest clauses)
"Define Component NAME from prop ARGUMENTS and 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) (etaf-define-component NAME (&key PROPS)
[:setup SETUP]
:view VIEW :view VIEW
:styles (styles (SELECTOR ATTR ...))) :styles (styles (SELECTOR ATTR ...)))
or: or:
(etaf-define-component NAME (&key PROPS) (etaf-define-component NAME (&key PROPS)
:setup SETUP [:setup SETUP]
:render ORDINARY-ELISP
:styles (styles (SELECTOR ATTR ...))) :styles (styles (SELECTOR ATTR ...)))
`:view' is rendered for every update. `:setup' runs once per retained `:setup' runs once per retained identity and returns opaque state. `:view'
Component instance and must return a zero-argument render function. View is unquoted DSL; `:render' is ordinary Elisp and constructs nodes with
forms do not use quote; ordinary Elisp belongs in `expr :value'." `etaf-node'."
(declare (indent 2) (debug defun)) (declare (indent 2) (debug defun))
(unless (symbolp name) (unless (symbolp name)
(etaf--component-definition-error (etaf--component-definition-error
"Component name must be a symbol: %S" name)) "Component name must be a symbol: %S" name))
(let ((docstring (when (stringp (car clauses)) (pop clauses))) (let ((docstring (when (stringp (car clauses)) (pop clauses)))
view-form view-form
render-form
setup-form setup-form
styles-form styles-form
saw-view saw-view
saw-render
saw-setup saw-setup
saw-styles) saw-styles)
(while clauses (while clauses
@ -202,6 +258,11 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(etaf--component-definition-error (etaf--component-definition-error
"Component %S has duplicate :view" name)) "Component %S has duplicate :view" name))
(setq view-form (pop clauses) saw-view t)) (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 (:setup
(when saw-setup (when saw-setup
(etaf--component-definition-error (etaf--component-definition-error
@ -215,31 +276,48 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(_ (_
(etaf--component-definition-error (etaf--component-definition-error
"Unknown Component definition keyword %S" keyword))))) "Unknown Component definition keyword %S" keyword)))))
(when (and saw-view saw-setup) (when (and saw-view saw-render)
(etaf--component-definition-error (etaf--component-definition-error
"Component %S must choose :view or :setup, not both" name)) "Component %S must choose :view or :render, not both" name))
(unless (or saw-view saw-setup) (unless (or saw-view saw-render)
(etaf--component-definition-error (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)) (let* ((props (etaf--parse-component-props arguments))
(styles-form (etaf--validate-styles-form styles-form name)) (styles-form (etaf--validate-styles-form styles-form name))
(definition-symbol (definition-symbol
(intern (format "%s--etaf-component-definition" name))) (intern (format "%s--etaf-component-definition" name)))
(render-lambda (render-lambda
(when saw-view `(lambda (etaf--component-props etaf--component-slots)
`(lambda (etaf--component-props etaf--component-slots) (let ((etaf--current-component-props etaf--component-props)
(let ((etaf--current-component-props etaf--component-props) (etaf--current-component-slots etaf--component-slots)
(etaf--current-component-slots etaf--component-slots) (etaf--component-phase 'render))
(etaf--current-component-instance
etaf--current-component-instance))
(cl-symbol-macrolet (cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props) ,(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 (setup-lambda
(when saw-setup (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) (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 (cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props) ,(etaf--component-prop-symbol-macros props)
,setup-form)))))) ,setup-form))))))

1
etaf-context.el
View File

@ -73,6 +73,7 @@ unchanged.")
;;;###autoload ;;;###autoload
(defun etaf-provide (key value) (defun etaf-provide (key value)
"Provide VALUE under stable Context KEY to the current subtree." "Provide VALUE under stable Context KEY to the current subtree."
(etaf--assert-not-rendering 'provide-context)
(unless (etaf-context-p etaf--current-context) (unless (etaf-context-p etaf--current-context)
(error "ETAF provide requires Component setup or render context")) (error "ETAF provide requires Component setup or render context"))
(puthash (etaf--context-key key) value (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; When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
otherwise call the local callback with no arguments." otherwise call the local callback with no arguments."
(etaf--assert-not-rendering 'dispatch-event)
(setq runtime (etaf-runtime-require-mounted runtime)) (setq runtime (etaf-runtime-require-mounted runtime))
(let ((dispatch (let ((dispatch
(lambda () (lambda ()

18
etaf-reactive.el
View File

@ -14,9 +14,12 @@
(require 'gv) (require 'gv)
(define-error 'etaf-reactive-error "Invalid ETAF reactive operation") (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 (define-error 'etaf-render-write-error
"ETAF state cannot be written while rendering" "ETAF state cannot be written while rendering"
'etaf-reactive-error) 'etaf-render-side-effect-error)
(cl-defstruct (etaf-ref (cl-defstruct (etaf-ref
(:constructor etaf--ref-create)) (:constructor etaf--ref-create))
@ -93,6 +96,11 @@
(defvar etaf--render-phase-p nil (defvar etaf--render-phase-p nil
"Whether the current call is producing a View tree.") "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 (defvar etaf--watch-scheduler nil
"Scheduler for watchers created in the current Scope. "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 SCHEDULER receives the effect when a dependency changes. SCOPE defaults to
the current Scope. NAME optionally labels the effect. ON-STOP runs once the current Scope. NAME optionally labels the effect. ON-STOP runs once
when the effect is disposed." when the effect is disposed."
(etaf--assert-not-rendering 'create-effect)
(unless (functionp function) (unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function))) (signal 'wrong-type-argument (list 'functionp function)))
(let* ((owner (or scope etaf--active-scope)) (let* ((owner (or scope etaf--active-scope))
@ -294,6 +303,7 @@ of the run."
"Create a writable shallow reactive cell containing INITIAL-VALUE. "Create a writable shallow reactive cell containing INITIAL-VALUE.
TEST optionally compares old and new values. NAME is used in diagnostics." TEST optionally compares old and new values. NAME is used in diagnostics."
(etaf--assert-not-rendering 'create-ref)
(when (and test (not (functionp test))) (when (and test (not (functionp test)))
(signal 'wrong-type-argument (list 'functionp test))) (signal 'wrong-type-argument (list 'functionp test)))
(etaf--ref-create :value initial-value (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 TEST optionally compares old and new values. NAME optionally labels the
computed value." computed value."
(etaf--assert-not-rendering 'create-computed)
(unless (functionp getter) (unless (functionp getter)
(signal 'wrong-type-argument (list 'functionp getter))) (signal 'wrong-type-argument (list 'functionp getter)))
(when (and test (not (functionp test))) (when (and test (not (functionp test)))
@ -398,6 +409,7 @@ computed value."
IMMEDIATE calls CALLBACK for the initial value. FLUSH is passed to the IMMEDIATE calls CALLBACK for the initial value. FLUSH is passed to the
current Runtime scheduler. TEST and NAME customize comparison and current Runtime scheduler. TEST and NAME customize comparison and
diagnostics. Return a stop function." diagnostics. Return a stop function."
(etaf--assert-not-rendering 'watch)
(unless (functionp callback) (unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback))) (signal 'wrong-type-argument (list 'functionp callback)))
(let* ((getter (etaf--watch-getter source)) (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 FLUSH selects the Runtime scheduler boundary. NAME optionally labels the
effect. If FUNCTION returns a function, it cleans up the previous run." effect. If FUNCTION returns a function, it cleans up the previous run."
(etaf--assert-not-rendering 'watch-effect)
(unless (functionp function) (unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function))) (signal 'wrong-type-argument (list 'functionp function)))
(let (cleanup effect job) (let (cleanup effect job)
@ -466,6 +479,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload ;;;###autoload
(cl-defun etaf-effect-scope (&key detached name) (cl-defun etaf-effect-scope (&key detached name)
"Create a Scope named NAME, owned by the current Scope unless DETACHED." "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)) (let* ((parent (and (not detached) etaf--active-scope))
(scope (etaf--effect-scope-create :parent parent :name name))) (scope (etaf--effect-scope-create :parent parent :name name)))
(when parent (when parent
@ -492,6 +506,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload ;;;###autoload
(defun etaf-on-scope-dispose (function) (defun etaf-on-scope-dispose (function)
"Register FUNCTION to run when the current Scope is disposed." "Register FUNCTION to run when the current Scope is disposed."
(etaf--assert-not-rendering 'register-scope-cleanup)
(unless (functionp function) (unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function))) (signal 'wrong-type-argument (list 'functionp function)))
(unless etaf--active-scope (unless etaf--active-scope
@ -502,6 +517,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload ;;;###autoload
(defun etaf-scope-stop (scope) (defun etaf-scope-stop (scope)
"Dispose SCOPE and return cleanup errors collected during teardown." "Dispose SCOPE and return cleanup errors collected during teardown."
(etaf--assert-not-rendering 'stop-scope)
(when (and (etaf-effect-scope-p scope) (when (and (etaf-effect-scope-p scope)
(etaf-effect-scope-active-p scope)) (etaf-effect-scope-active-p scope))
(setf (etaf-effect-scope-active-p scope) nil) (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." structure must use the ordinary typed lowering path."
(cond (cond
((stringp value) (cons t value)) ((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)))) (let ((result (funcall (etaf--expr-thunk value))))
(if (stringp result) (cons t result) (cons nil nil)))) (if (stringp result) (cons t result) (cons nil nil))))
((etaf--view-node-p value) (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) (defun etaf--inline-text-structural-p (value)
"Return non-nil when VALUE can be owned by mounted inline effects." "Return non-nil when VALUE can be owned by mounted inline effects."
(cond (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) ((etaf--view-node-p value) nil)
((proper-list-p value) ((proper-list-p value)
(cl-every #'etaf--inline-text-structural-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) (defun etaf--inline-text-dynamic-p (value)
"Return non-nil when VALUE contains an inline `expr' update site." "Return non-nil when VALUE contains an inline `expr' update site."
(cond (cond
((etaf--expr-p value) t) ((and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation)) t)
((etaf--view-node-p value) ((etaf--view-node-p value)
(cl-some #'etaf--inline-text-dynamic-p (cl-some #'etaf--inline-text-dynamic-p
(etaf--view-node-children value))) (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)) (etaf--component-call-p value) (etaf--slot-projection-p value))
(list value)) (list value))
((etaf--expr-p 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) ((proper-list-p value)
(cl-mapcan #'etaf--flatten-view-value value)) (cl-mapcan #'etaf--flatten-view-value value))
(t (t
@ -597,7 +619,8 @@ multi-root forest; a single material root is returned unchanged."
(let ((etaf--current-component-props (let ((etaf--current-component-props
(etaf--component-call-props call)) (etaf--component-call-props call))
(etaf--current-component-slots (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) (let ((etaf--render-parent-style-stack etaf--render-style-stack)
(etaf--render-style-stack (etaf--render-style-stack
(list (cons (etaf--component-spec-styles spec) (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 (let ((etaf--current-semantic-parent-id
(or semantic-id (or semantic-id
etaf--current-semantic-parent-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)) (not etaf--rendering-range-p))
(let ((result (let ((result
(etaf--runtime-render-child-range (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 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 SCOPE is nil. Without any parent Scope it creates a detached Scope.
When IMMEDIATE is non-nil, load the Resource before returning it." When IMMEDIATE is non-nil, load the Resource before returning it."
(etaf--assert-not-rendering 'create-resource)
(unless (functionp loader) (unless (functionp loader)
(signal 'wrong-type-argument (list 'functionp loader))) (signal 'wrong-type-argument (list 'functionp loader)))
(let* ((parent (etaf--resource-parent-scope scope)) (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 Only LOADER errors are captured into Resource state. Cleanup failures and
wrong Resource usage continue to signal normally." wrong Resource usage continue to signal normally."
(etaf--assert-not-rendering 'load-resource)
(etaf--resource-require-active resource) (etaf--resource-require-active resource)
(etaf--resource-run-cleanup resource) (etaf--resource-run-cleanup resource)
(etaf--resource-set-state resource 'loading nil nil) (etaf--resource-set-state resource 'loading nil nil)
@ -161,6 +163,7 @@ wrong Resource usage continue to signal normally."
;;;###autoload ;;;###autoload
(defun etaf-resource-dispose (resource) (defun etaf-resource-dispose (resource)
"Dispose RESOURCE and return cleanup errors collected by its Scope." "Dispose RESOURCE and return cleanup errors collected by its Scope."
(etaf--assert-not-rendering 'dispose-resource)
(unless (etaf-resource-p resource) (unless (etaf-resource-p resource)
(signal 'wrong-type-argument (list 'etaf-resource-p resource))) (signal 'wrong-type-argument (list 'etaf-resource-p resource)))
(when (etaf-resource-active-p resource) (when (etaf-resource-active-p resource)

468
etaf-runtime.el
View File

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

387
etaf-view.el
View File

@ -29,7 +29,8 @@
(cl-defstruct (etaf--expr (cl-defstruct (etaf--expr
(:constructor etaf--expr-create)) (:constructor etaf--expr-create))
"Internal executable child expression." "Internal executable interpolation or compiler-owned structural program."
(kind 'interpolation)
token token
thunk thunk
range-snapshot range-snapshot
@ -75,6 +76,9 @@ this list merely to make a demo convenient.")
(defconst etaf--host-marker 'etaf--host (defconst etaf--host-marker 'etaf--host
"Value stored in the View registry for a built-in 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 (defconst etaf--ordinary-elisp-heads
'(and or not if when unless cond case pcase '(and or not if when unless cond case pcase
let let* letrec letrec* prog prog1 prog2 progn let let* letrec letrec* prog prog1 prog2 progn
@ -105,6 +109,9 @@ disposing the old Runtime.")
(defvar etaf--current-component-instance nil (defvar etaf--current-component-instance nil
"Dynamic Component instance currently being evaluated.") "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) (defun etaf--syntax-error (format-string &rest arguments)
"Signal a View syntax error formatted from FORMAT-STRING and ARGUMENTS." "Signal a View syntax error formatted from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-view-syntax-error (signal 'etaf-view-syntax-error
@ -119,25 +126,8 @@ disposing the old Runtime.")
"Return the property keyword corresponding to symbol NAME." "Return the property keyword corresponding to symbol NAME."
(intern (concat ":" (symbol-name 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) (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)) (unless (and (symbolp name) (etaf--component-spec-p spec))
(signal 'wrong-type-argument (list 'etaf--component-spec-p spec))) (signal 'wrong-type-argument (list 'etaf--component-spec-p spec)))
(let ((existing (gethash name etaf--view-registry))) (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 (etaf--component-error
"Component %S is already registered" name))) "Component %S is already registered" name)))
(puthash name spec etaf--view-registry) (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) (when (fboundp 'etaf-compiler-note-registry-change)
(etaf-compiler-note-registry-change)) (etaf-compiler-note-registry-change))
spec) spec)
(defun etaf--register-core-hosts () (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) (dolist (name etaf--host-names)
(puthash name etaf--host-marker etaf--view-registry) (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))
(etaf--register-core-hosts) (etaf--register-core-hosts)
@ -237,12 +207,11 @@ form, or core Host. A collision receives a semantic `-view' alias."
compiled)) compiled))
(defun etaf--validate-key (key) (defun etaf--validate-key (key)
"Validate a Host identity KEY and return it." "Validate identity KEY and return its immutable boundary value."
(unless (or (null key) (symbolp key) (stringp key) (unless (and key (or (symbolp key) (stringp key) (integerp key)))
(integerp key) (floatp key))
(etaf--component-error (etaf--component-error
"View keys must be immutable scalar values: %S" key)) "View keys must be non-nil symbols, integers, or strings: %S" key))
key) (if (stringp key) (copy-sequence key) key))
(defun etaf--parse-attributes-and-children (items) (defun etaf--parse-attributes-and-children (items)
"Split structural ITEMS into `(PROPS . CHILDREN)'. "Split structural ITEMS into `(PROPS . CHILDREN)'.
@ -273,18 +242,10 @@ the generated code."
(cons (nreverse props) (nreverse children)))) (cons (nreverse props) (nreverse children))))
(defun etaf--parse-expr-form (items) (defun etaf--parse-expr-form (items)
"Return the value form from an `expr' child with ITEMS. "Return the sole ordinary Elisp form from interpolation ITEMS."
(unless (= (length items) 1)
`expr' intentionally has one property, `:value', and no children." (etaf--syntax-error "Expr accepts exactly one form: (expr FORM)"))
(let ((parts (etaf--parse-attributes-and-children items))) (car 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))))
(defun etaf--constant-slot-name (form) (defun etaf--constant-slot-name (form)
"Return the static slot symbol represented by FORM, or signal an error." "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." "Compile an `expr' form with ITEMS into an executable View value."
(let ((token (gensym "etaf-expr-site-"))) (let ((token (gensym "etaf-expr-site-")))
`(etaf--expr-create `(etaf--expr-create
:kind 'interpolation
:token ',token :token ',token
:thunk (lambda () ,(etaf--parse-expr-form items))))) :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) (defun etaf--compile-child-form (form &optional slot-mode)
"Compile structural child FORM into code returning a View value. "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)) ((and (consp form) (eq (car form) 'slot))
(etaf--compile-slot-form (cdr form) slot-mode)) (etaf--compile-slot-form (cdr form) slot-mode))
((and (consp form) (symbolp (car form))) ((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 (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)) (etaf--compile-view-form form slot-mode))
((consp form) ((consp form)
(etaf--syntax-error "Invalid View child form: %S" 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-")))) (gensym "etaf-fragment-site-"))))
`(etaf--view-call ',(car form) `(etaf--view-call ',(car form)
(list ,@(etaf--compile-property-plist props)) (list ,@(etaf--compile-property-plist props))
(list ,@(mapcar (lambda (child) (list ,@(etaf--compile-child-sequence
(etaf--compile-child-form children child-slot-mode))
child child-slot-mode))
children))
,(and token `',token))))))) ,(and token `',token)))))))
;;;###autoload ;;;###autoload
@ -411,8 +593,7 @@ FORM uses one grammar for Hosts and Component calls:
(NAME :PROPERTY VALUE ... CHILD ...) (NAME :PROPERTY VALUE ... CHILD ...)
Properties must come first and children must come last. Property values are Properties must come first and children must come last. Property values are
ordinary Elisp expressions. `expr' is the only computation bridge in the ordinary Elisp expressions. `(expr FORM)' is text interpolation only."
child region and accepts only `:value'."
(declare (indent 1) (debug (form))) (declare (indent 1) (debug (form)))
(if (fboundp 'etaf-compiler-expand-view) (if (fboundp 'etaf-compiler-expand-view)
(etaf-compiler-expand-view form :projection) (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))))) key (etaf--component-spec-name spec)))))
props)) 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) (defun etaf--text-view-from-string (value)
"Return one normalized Text View containing string VALUE." "Return one normalized Text View containing string VALUE."
(etaf--view-node-create :name 'text :props nil :children (list 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)) (setq props (etaf--validate-property-plist props))
(let* ((entry (gethash name etaf--view-registry)) (let* ((entry (gethash name etaf--view-registry))
(host-name (and (eq entry etaf--host-marker) (host-name (and (eq entry etaf--host-marker)
(etaf--canonical-host-name name))) name))
(children (children
(if (eq host-name 'text) (if (eq host-name 'text)
children children

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

@ -5,10 +5,6 @@
(require 'ert) (require 'ert)
(require 'etaf) (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) (defun etaf-compiler-test--canonical (value)
"Return VALUE as comparable View data, resolving lazy holes once." "Return VALUE as comparable View data, resolving lazy holes once."
(cond (cond
@ -27,42 +23,31 @@
((null value) nil) ((null value) nil)
(t value))) (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) (defun etaf-compiler-test--lowered (color text)
"Return an automatically lowered fixture using COLOR and TEXT." "Return an automatically lowered fixture using COLOR and TEXT."
(etaf-view (etaf-view
(column :color color (column :color color
(column :padding '(1 2) (column :padding '(1 2)
(text "static")) (text "static"))
(text (expr :value text))))) (text (expr text)))))
(defun etaf-compiler-test--fallback-view () (defun etaf-compiler-test--slot-view ()
"Return a View containing unsupported slot grammar." "Return a blueprint-backed View containing a slot projection."
(etaf-view (etaf-view
(column (slot (text "fallback"))))) (column (slot (text "fallback")))))
(defun etaf-compiler-test--fallback-reference () (ert-deftest etaf-automatic-view-slot-uses-current-blueprint-abi ()
"Return the interpreted reference for `etaf-compiler-test--fallback-view'." "Slot projection is a `/2' block and never takes a compatibility path."
(etaf-compiler-test--legacy-view (let* ((before (plist-get (etaf-compiler-statistics) :instantiations))
(column (slot (text "fallback"))))) (view (etaf-compiler-test--slot-view))
(after (etaf-compiler-statistics))
(ert-deftest etaf-automatic-view-fallback-is-exact () (root (plist-get etaf-compiler--last-blueprint :root)))
"An unsupported slot keeps the existing View semantics." (should (etaf--slot-projection-p
(let ((before (plist-get (etaf-compiler-statistics) :fallbacks))) (car (etaf--view-node-children view))))
(should (should (eq 'slot
(equal (etaf-compiler-test--canonical (plist-get (car (plist-get root :children)) :kind)))
(etaf-compiler-test--fallback-view)) (should (= (1+ before) (plist-get after :instantiations)))
(etaf-compiler-test--canonical (should-not (plist-member after :fallbacks))))
(etaf-compiler-test--fallback-reference))))
(should (= (1+ before)
(plist-get (etaf-compiler-statistics) :fallbacks)))))
(defun etaf-compiler-test--lowered-supported (color) (defun etaf-compiler-test--lowered-supported (color)
"Return a supported automatically lowered fixture using COLOR." "Return a supported automatically lowered fixture using COLOR."
@ -73,22 +58,18 @@
(text "static-b")) (text "static-b"))
(text :color "blue" "tail")))) (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 () (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 (should
(equal (etaf-compiler-test--canonical (equal (etaf-compiler-test--canonical
(etaf-compiler-test--lowered-supported "green")) (etaf-compiler-test--lowered-supported "green"))
(etaf-compiler-test--canonical '(:host column :props (:color "green")
(etaf-compiler-test--interpreted-supported "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 () (ert-deftest etaf-automatic-view-reuses-static-subtrees ()
"Repeated instantiation reuses a static child while rebuilding its root." "Repeated instantiation reuses a static child while rebuilding its root."
@ -111,14 +92,7 @@
(cl-incf calls) (cl-incf calls)
(apply original arguments)))) (apply original arguments))))
(etaf-compiler-test--lowered-supported "next")) (etaf-compiler-test--lowered-supported "next"))
(should (= calls 1)) (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))))
(ert-deftest etaf-automatic-view-exposes-blueprint-coverage () (ert-deftest etaf-automatic-view-exposes-blueprint-coverage ()
"The compiler reports static nodes, dynamic paths, and holes." "The compiler reports static nodes, dynamic paths, and holes."
@ -139,7 +113,7 @@
"Expr becomes one dynamic child program without forcing root fallback." "Expr becomes one dynamic child program without forcing root fallback."
(pcase-let* ((`(,blueprint . ,programs) (pcase-let* ((`(,blueprint . ,programs)
(etaf-compiler--compile (etaf-compiler--compile
'(column (text (expr :value value))))) '(column (text (expr value)))))
(root (plist-get blueprint :root)) (root (plist-get blueprint :root))
(text-block (car (plist-get root :children))) (text-block (car (plist-get root :children)))
(expr-block (car (plist-get text-block :children)))) (expr-block (car (plist-get text-block :children))))
@ -147,5 +121,29 @@
(should-not (plist-get root :static-p)) (should-not (plist-get root :static-p))
(should (= (length programs) 1)))) (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) (provide 'etaf-compiler-tests)
;;; etaf-compiler-tests.el ends here ;;; 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