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

perf: expose scoped ETAF operation observation

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-28 00:46:09 +08:00
parent e91956b422
commit bcb7254350
12 changed files with 935 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -1,8 +1,8 @@
EMACS ?= emacs
LOAD_PATH = -L . -L examples -L ../ebox -L ../tp -L ../ecss
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el
EXAMPLES = examples/etaf-counter-example.el examples/etaf-data-example.el examples/etaf-resource-example.el
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-performance-tests.el
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el
.PHONY: test compile load checkdoc docs-check check clean

11
etaf-actions.el
View File

@ -14,6 +14,11 @@
(require 'etaf-runtime)
(defvar etaf--current-runtime)
(defvar etaf--observer-context)
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
(declare-function etaf-runtime-call-operation
"etaf-runtime" (runtime kind label function))
(define-error 'etaf-action-error "Invalid ETAF Action")
@ -77,8 +82,14 @@ RUNTIME ACTION ...)'. Action functions receive Runtime first."
(unless spec
(signal 'etaf-action-error
(list (format "Unknown ETAF Action: %S" action))))
(if (or etaf--observer-context (etaf-runtime-observer runtime))
(etaf-runtime-call-operation
runtime 'action (format "%S" action)
(lambda ()
(let ((etaf--current-runtime runtime))
(apply (etaf-action-spec-function spec) runtime arguments))))
(let ((etaf--current-runtime runtime))
(apply (etaf-action-spec-function spec) runtime arguments)))))
;;;###autoload
(defun etaf-action-undefine (name)

44
etaf-data.el
View File

@ -12,6 +12,7 @@
;;; Code:
(require 'cl-lib)
(require 'etaf-observer)
(require 'etaf-reactive)
(define-error 'etaf-data-error "Invalid ETAF data operation")
@ -48,16 +49,22 @@ CAPABILITIES is a plist. `:load' is required and receives QUERY, PAGE, and
PAGE-SIZE. It must return a plist containing at least `:items', and may return
`:total', `:page', and `:page-size'. `:mutate' is optional and receives
OPERATION and PAYLOAD. `:dispose' is optional and runs when the owning
controller stops."
controller stops. `:provider' may name the source in observation reports and
defaults to `data'."
(let ((load (plist-get capabilities :load))
(mutate (plist-get capabilities :mutate))
(dispose (plist-get capabilities :dispose)))
(dispose (plist-get capabilities :dispose))
(provider (plist-get capabilities :provider)))
(unless (functionp load)
(signal 'wrong-type-argument (list 'functionp load)))
(dolist (entry `((:mutate . ,mutate)
(:dispose . ,dispose)))
(when (and (cdr entry) (not (functionp (cdr entry))))
(signal 'wrong-type-argument (list 'functionp (cdr entry)))))
(when (and (plist-member capabilities :provider)
(not (and provider (symbolp provider)
(not (keywordp provider)))))
(signal 'wrong-type-argument (list 'symbolp provider)))
(append (list :etaf-data-source t) capabilities)))
(defun etaf-data-source-p (value)
@ -75,6 +82,25 @@ controller stops."
(error "ETAF Data source lacks %S capability" key))
function))
(defun etaf-data--source-provider (source)
"Return SOURCE's observation provider, defaulting to `data'."
(or (plist-get source :provider) 'data))
(defun etaf-data--source-load (source query page page-size)
"Invoke SOURCE load capability for QUERY, PAGE, and PAGE-SIZE."
(etaf-observer-with-stage
((etaf-data--source-provider source) 'load
:page page :page-size page-size)
(funcall (etaf-data--source-function source :load t)
query page page-size)))
(defun etaf-data--source-mutate (source operation payload)
"Invoke SOURCE mutation OPERATION with PAYLOAD."
(etaf-observer-with-stage
((etaf-data--source-provider source) 'mutate :operation operation)
(funcall (etaf-data--source-function source :mutate t)
operation payload)))
(defun etaf-data--record-value (record key)
"Return RECORD value at KEY for plist, alist, or hash table records."
(cond
@ -155,6 +181,7 @@ and `reset'."
current))))
(etaf-data-source
:name name
:provider 'memory
:load (lambda (query page page-size)
(let* ((all (etaf-value records))
(filtered (funcall query-function query all)))
@ -213,9 +240,10 @@ and `reset'."
QUERY is passed through unchanged. PAGE and PAGE-SIZE default to 1 and 20.
This public preparation boundary performs no reactive publication; callers may
use its result as `:initial-result' for `etaf-data-controller'."
(let ((page (max 1 (or page 1)))
(page-size (max 1 (or page-size 20))))
(etaf-data--normalize-result
(funcall (etaf-data--source-function source :load t)
query (max 1 (or page 1)) (max 1 (or page-size 20)))))
(etaf-data--source-load source query page page-size))))
(defun etaf-data--apply-load-success (controller request-id result)
"Publish successful RESULT for CONTROLLER when REQUEST-ID is current."
@ -381,8 +409,8 @@ load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive."
(etaf-data--apply-load-success
controller
request-id
(funcall (etaf-data--source-function
(etaf-data--controller-source controller) :load t)
(etaf-data--source-load
(etaf-data--controller-source controller)
(etaf-value (etaf-data--controller-query controller))
(etaf-value (etaf-data--controller-page controller))
(etaf-value (etaf-data--controller-page-size controller))))
@ -408,8 +436,8 @@ source mutation result after the reload succeeds."
(setf (etaf-value (etaf-data--controller-error controller)) nil)
(condition-case err
(let ((result
(funcall (etaf-data--source-function
(etaf-data--controller-source controller) :mutate t)
(etaf-data--source-mutate
(etaf-data--controller-source controller)
operation payload)))
(etaf-data-load controller)
result)

13
etaf-events.el
View File

@ -15,6 +15,7 @@
(require 'etaf-runtime)
(defvar etaf--current-runtime)
(defvar etaf--observer-context)
(declare-function etaf-runtime-require-mounted "etaf-runtime" (&optional runtime))
(declare-function etaf-runtime-p "etaf-runtime" (value))
@ -28,6 +29,9 @@
(declare-function etaf-runtime-set-focus-ref "etaf-runtime" (runtime host-ref))
(declare-function etaf-runtime-event-begin "etaf-runtime" (runtime))
(declare-function etaf-runtime-event-end "etaf-runtime" (runtime))
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
(declare-function etaf-runtime-call-operation
"etaf-runtime" (runtime kind label function))
(declare-function ebox-call-with-render-burst
"ebox-buffer-backend" (function &rest arguments))
@ -61,9 +65,9 @@
When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
otherwise call the local callback with no arguments."
(setq runtime (etaf-runtime-require-mounted runtime))
(let ((dispatch
(lambda ()
(setq runtime (etaf-runtime-require-mounted runtime))
(let ((callback (etaf--event-handler runtime host-ref kind)))
(unless callback
(signal 'etaf-event-error
@ -79,7 +83,12 @@ otherwise call the local callback with no arguments."
(funcall callback payload)
(funcall callback))
(etaf-runtime-event-end runtime)))))))
(ebox-call-with-render-burst dispatch)))
(if (or etaf--observer-context (etaf-runtime-observer runtime))
(etaf-runtime-call-operation
runtime 'event
(format "%s %S" (etaf-event-kind kind) host-ref)
(lambda () (ebox-call-with-render-burst dispatch)))
(ebox-call-with-render-burst dispatch))))
;;;###autoload
(defun etaf-host-ref-bounds (runtime host-ref)

202
etaf-observer.el Normal file
View File

@ -0,0 +1,202 @@
;;; etaf-observer.el --- Scoped ETAF Runtime observation -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This file defines the deliberately small observation port used by the ETAF
;; Runtime. Observation is scoped to one dynamic operation; it is neither a
;; global subscription service nor publication authority. When no context is
;; active, instrumented stages execute their original body directly.
;;; Code:
(require 'cl-lib)
(define-error 'etaf-observer-error "Invalid ETAF observer operation")
(defconst etaf-observer-report-format-version 1
"Format version of flat ETAF observation reports.")
(defconst etaf--observer-context-keys
'(:format-version :operation-id :sequence :runtime-id :buffer-name)
"Report fields owned exclusively by the active operation context.")
(cl-defstruct (etaf--observer-context
(:constructor etaf--observer-context--make))
"Dynamic observation state for one ETAF Runtime operation."
sink
operation-id
runtime-id
buffer-name
(sequence 0)
diagnostic)
(defvar etaf--observer-context nil
"Dynamically active ETAF observation context, or nil.")
(defun etaf--observer-provider-report-valid-p (report)
"Return non-nil when REPORT is a valid provider report."
(and (proper-list-p report)
(zerop (% (length report) 2))
(let ((tail report)
keys
valid)
(setq valid t)
(while (and tail valid)
(let ((key (pop tail)))
(pop tail)
(setq valid
(and (keywordp key)
(not (memq key keys))
(not (memq key etaf--observer-context-keys))))
(push key keys)))
(and valid
(plist-member report :provider)
(let ((provider (plist-get report :provider)))
(and provider (symbolp provider) (not (keywordp provider))))
(plist-member report :stage)
(let ((stage (plist-get report :stage)))
(and stage (symbolp stage) (not (keywordp stage))))
(or (not (plist-member report :status))
(memq (plist-get report :status) '(success error quit)))
(plist-member report :duration-ms)
(numberp (plist-get report :duration-ms))
(>= (plist-get report :duration-ms) 0)))))
(defun etaf--observer-copy-value (value)
"Return a defensive observation copy of VALUE."
(cond
((stringp value) (copy-sequence value))
((consp value)
(cons (etaf--observer-copy-value (car value))
(etaf--observer-copy-value (cdr value))))
((vectorp value)
(apply #'vector
(mapcar #'etaf--observer-copy-value (append value nil))))
(t value)))
(defun etaf--observer-report-copy (report)
"Return an isolated snapshot of validated provider REPORT."
(etaf--observer-copy-value report))
(defun etaf--observer-diagnose (kind condition)
"Contain KIND and CONDITION with the active context diagnostic sink."
(when-let* ((context etaf--observer-context)
(diagnostic (etaf--observer-context-diagnostic context)))
(let ((inhibit-quit t)
(quit-flag nil))
(condition-case nil
(funcall diagnostic
(list :kind kind :condition (copy-tree condition)))
((error quit) nil))))
nil)
(cl-defun etaf--observer-context-create
(&key sink operation-id runtime-id buffer-name diagnostic)
"Create scoped observer state for one Runtime operation.
SINK receives one defensive report snapshot. OPERATION-ID and RUNTIME-ID are
stable scalar identities, BUFFER-NAME is a string or nil, and DIAGNOSTIC
receives contained observer-port failures. This internal constructor is the
only Runtime entry point that allocates observation state."
(unless (functionp sink)
(signal 'etaf-observer-error '(Observer sink must be a function)))
(unless (integerp operation-id)
(signal 'etaf-observer-error '(Operation identity must be an integer)))
(unless (integerp runtime-id)
(signal 'etaf-observer-error '(Runtime identity must be an integer)))
(unless (or (null buffer-name) (stringp buffer-name))
(signal 'etaf-observer-error '(Buffer name must be a string or nil)))
(unless (functionp diagnostic)
(signal 'etaf-observer-error '(Diagnostic sink must be a function)))
(etaf--observer-context--make
:sink sink
:operation-id operation-id
:runtime-id runtime-id
:buffer-name (and buffer-name (copy-sequence buffer-name))
:diagnostic diagnostic))
(defun etaf--observer-call-with-context (context function)
"Call FUNCTION with internal observer CONTEXT dynamically active."
(unless (etaf--observer-context-p context)
(signal 'etaf-observer-error '(Invalid observer context)))
(unless (functionp function)
(signal 'etaf-observer-error '(Observed operation must be a function)))
(let ((etaf--observer-context context))
(funcall function)))
(defun etaf-observer-emit (report)
"Decorate and deliver immutable provider REPORT in the active context.
The observer receives a defensive copy. Observer errors, quits, and invalid
reports are contained by the context diagnostic sink and never affect product
execution. The dynamic context is cleared during delivery so an observer can
reenter ETAF without recursively observing itself."
(when etaf--observer-context
(if (not (etaf--observer-provider-report-valid-p report))
(etaf--observer-diagnose 'invalid-report report)
(let* ((context etaf--observer-context)
(sequence (1+ (etaf--observer-context-sequence context)))
(sink (etaf--observer-context-sink context))
(provider-report (etaf--observer-report-copy report))
(snapshot
(append
(list :format-version etaf-observer-report-format-version
:operation-id
(etaf--observer-context-operation-id context)
:sequence sequence
:runtime-id (etaf--observer-context-runtime-id context)
:buffer-name
(etaf--observer-copy-value
(etaf--observer-context-buffer-name context)))
provider-report
(unless (plist-member provider-report :status)
(list :status 'success))))
(inhibit-quit t)
(quit-flag nil))
(setf (etaf--observer-context-sequence context) sequence)
(condition-case condition
(let ((etaf--observer-context nil))
(funcall sink snapshot))
((error quit)
(etaf--observer-diagnose 'observer-failure condition))))))
nil)
(defun etaf--observer-finish-stage (provider stage metadata status started)
"Emit PROVIDER STAGE with METADATA, STATUS, and STARTED timestamp."
(let ((duration-ms (max 0.0 (* 1000.0 (- (float-time) started)))))
(etaf-observer-emit
(append (list :provider provider :stage stage :status status
:duration-ms duration-ms)
metadata))))
(defun etaf--observer-call-stage (provider stage metadata function)
"Call observed PROVIDER STAGE FUNCTION with METADATA."
(let ((started (float-time)))
(condition-case condition
(prog1 (funcall function)
(etaf--observer-finish-stage
provider stage metadata 'success started))
(quit
(etaf--observer-finish-stage provider stage metadata 'quit started)
(signal (car condition) (cdr condition)))
(error
(etaf--observer-finish-stage provider stage metadata 'error started)
(signal (car condition) (cdr condition))))))
(cl-defmacro etaf-observer-with-stage
((provider stage &rest metadata) &rest body)
"Execute BODY as PROVIDER STAGE with optional METADATA.
The nil path is a single branch directly to BODY: it takes no timestamp,
allocates no closure or report, and reads no garbage-collection state."
(declare (indent 1) (debug ((form form &rest form) body)))
`(if (null etaf--observer-context)
(progn ,@body)
(etaf--observer-call-stage
,provider ,stage (list ,@metadata) (lambda () ,@body))))
(provide 'etaf-observer)
;;; etaf-observer.el ends here

4
etaf-resource.el
View File

@ -12,6 +12,7 @@
;;; Code:
(require 'cl-lib)
(require 'etaf-observer)
(require 'etaf-reactive)
(define-error 'etaf-resource-error "Invalid ETAF Resource operation"
@ -142,9 +143,10 @@ wrong Resource usage continue to signal normally."
(let (result error-data)
(condition-case err
(setq result
(etaf-observer-with-stage ('resource 'load)
(etaf-scope-run
(etaf-resource-scope resource)
(etaf-resource-loader resource)))
(etaf-resource-loader resource))))
(error (setq error-data err)))
(if error-data
(etaf--resource-set-state resource 'error nil error-data)

216
etaf-runtime.el
View File

@ -18,6 +18,7 @@
(require 'etaf-renderer)
(require 'etaf-context)
(require 'etaf-behavior)
(require 'etaf-observer)
(declare-function etaf--render-value-list "etaf-renderer" (value path))
(declare-function etaf--apply-inline-style-rules "etaf-renderer" (node styles &optional root-p))
@ -47,6 +48,8 @@
(defvar etaf--render-style-stack)
(defvar etaf--render-parent-style-stack)
(defvar etaf--current-context)
(defvar gcs-done)
(defvar gc-elapsed)
(define-error 'etaf-runtime-error "ETAF runtime error")
@ -326,6 +329,8 @@ the sequential `etaf--pvec-put' contract."
flushing-p
pending-p
diagnostics
observer
(next-operation-id 0)
(event-depth 0)
dirty-effect-queue-tail)
@ -1086,6 +1091,104 @@ effect-to-source edges. It is intentionally immutable and suitable as an
"Return the dynamically active Runtime, or nil outside a Runtime."
etaf--current-runtime)
(defun etaf--runtime-forward-ebox-report (_buffer report)
"Forward accepted Ebox or TP REPORT into the active Runtime operation."
(etaf-observer-emit report))
(defun etaf--runtime-record-observer-diagnostic (runtime diagnostic)
"Record contained observer DIAGNOSTIC on RUNTIME."
(push (append (list :phase 'observer) (copy-tree diagnostic))
(etaf-runtime-diagnostics runtime))
nil)
(defun etaf-runtime-call-operation (runtime kind label function)
"Call FUNCTION as one observed RUNTIME operation.
KIND is a stable symbol and LABEL is a user-facing string. Nested calls for
the same Runtime reuse the active operation. Calls for another Runtime own a
separate operation. Return FUNCTION's exact result and re-signal its exact
error or quit."
(unless (and (etaf-runtime-p runtime)
(etaf-runtime-mounted-p runtime))
(signal 'etaf-runtime-error (list "ETAF runtime is not mounted")))
(unless (and (symbolp kind) kind)
(signal 'wrong-type-argument (list 'symbolp kind)))
(unless (stringp label)
(signal 'wrong-type-argument (list 'stringp label)))
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let* ((runtime-id (etaf-runtime-mount-epoch runtime))
(current etaf--observer-context)
(same-runtime
(and current
(= runtime-id
(etaf--observer-context-runtime-id current))))
(observer (etaf-runtime-observer runtime)))
(cond
(same-runtime
(funcall function))
((null observer)
;; A different Runtime must not leak provider reports into the outer
;; operation merely because its own observer is disabled.
(let ((etaf--observer-context nil))
(funcall function)))
(t
(let* ((operation-id
(1+ (or (etaf-runtime-next-operation-id runtime) 0)))
(generation-before (etaf-runtime-generation runtime))
(started (float-time))
(gc-count-before gcs-done)
(gc-elapsed-before gc-elapsed)
(status 'error)
(context
(etaf--observer-context-create
:sink observer
:operation-id operation-id
:runtime-id runtime-id
:buffer-name (buffer-name (etaf-runtime-buffer runtime))
:diagnostic
(lambda (diagnostic)
(etaf--runtime-record-observer-diagnostic
runtime diagnostic))))
result)
(setf (etaf-runtime-next-operation-id runtime) operation-id)
(etaf--observer-call-with-context
context
(lambda ()
(unwind-protect
(condition-case condition
(prog1 (setq result (funcall function))
(setq status 'success))
(quit
(setq status 'quit)
(signal (car condition) (cdr condition))))
(etaf-observer-emit
(list
:provider 'etaf
:stage 'runtime-operation
:kind kind
:label (copy-sequence label)
:generation-before generation-before
:generation-after (etaf-runtime-generation runtime)
:status status
:duration-ms
(max 0.0 (* 1000.0 (- (float-time) started)))
:gc-count (- gcs-done gc-count-before)
:gc-duration-ms
(max 0.0
(* 1000.0 (- gc-elapsed gc-elapsed-before))))))))
result)))))
(cl-defmacro etaf--runtime-with-operation ((runtime kind label) &rest body)
"Evaluate BODY in RUNTIME operation KIND and LABEL when observed."
(declare (indent 1) (debug ((form form form) body)))
(let ((runtime-value (make-symbol "runtime")))
`(let ((,runtime-value ,runtime))
(if (and (null etaf--observer-context)
(null (etaf-runtime-observer ,runtime-value)))
(progn ,@body)
(etaf-runtime-call-operation
,runtime-value ,kind ,label (lambda () ,@body))))))
(defun etaf-runtime-set-focus-ref (runtime host-ref)
"Set RUNTIME's focused Host reference to HOST-REF and return it."
(setf (etaf-runtime-focus-ref runtime) host-ref)
@ -1128,6 +1231,44 @@ when the requested boundary is no longer mounted."
(list "ETAF runtime is not mounted")))
runtime))
;;;###autoload
(defun etaf-runtime-set-observer (runtime observer-or-nil)
"Set mounted RUNTIME's observer to OBSERVER-OR-NIL and return it.
The observer receives one immutable flat report argument. Nil detaches the
Runtime from its Ebox surface. Replacing observation during an active
operation is rejected so the operation keeps one stable sink."
(setq runtime (etaf-runtime-require-mounted runtime))
(unless (or (null observer-or-nil) (functionp observer-or-nil))
(signal 'wrong-type-argument (list 'functionp observer-or-nil)))
(unless (eq observer-or-nil (etaf-runtime-observer runtime))
(when (and etaf--observer-context
(= (etaf-runtime-mount-epoch runtime)
(etaf--observer-context-runtime-id
etaf--observer-context)))
(error "ETAF observer cannot change during an active operation"))
(ebox-buffer-set-observer
(etaf-runtime-buffer runtime)
(and observer-or-nil #'etaf--runtime-forward-ebox-report))
(setf (etaf-runtime-observer runtime) observer-or-nil))
observer-or-nil)
;;;###autoload
(defun etaf-runtime-compare-and-set-observer (runtime expected replacement)
"Replace RUNTIME observer EXPECTED with REPLACEMENT atomically.
EXPECTED and REPLACEMENT are functions or nil. Return non-nil only when the
current observer is `eq' to EXPECTED; in that case REPLACEMENT is installed
through the ordinary observer boundary. A mismatch leaves the Runtime
untouched. This lets optional consumers detach only the sink they own without
reading Runtime storage fields."
(setq runtime (etaf-runtime-require-mounted runtime))
(dolist (observer (list expected replacement))
(unless (or (null observer) (functionp observer))
(signal 'wrong-type-argument (list 'functionp observer))))
(when (eq expected (etaf-runtime-observer runtime))
(etaf-runtime-set-observer runtime replacement)
t))
(defun etaf--runtime-watch-scheduler (runtime job _flush)
"Run watcher JOB while RUNTIME remains mounted."
(when (etaf-runtime-mounted-p runtime)
@ -4975,7 +5116,10 @@ RENDERED-IDENTITIES names the Component render participants."
(etaf--runtime-participant-publish participant))
(lambda (_report)
(etaf--runtime-participant-rollback participant))))
(ebox-render-to-buffer (etaf-runtime-buffer runtime) next-root)
(ebox-render-to-buffer
(etaf-runtime-buffer runtime) next-root
(when (etaf-runtime-observer runtime)
(list :observer #'etaf--runtime-forward-ebox-report)))
(etaf--runtime-participant-publish participant))
(etaf--runtime-complete-generation
runtime old-generation candidate-generation)
@ -5018,8 +5162,8 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(etaf--runtime-evaluate-root-candidate runtime))
(etaf--runtime-render-effect runtime)))
(defun etaf--runtime-request-flush (runtime)
"Synchronously flush RUNTIME, or mark one follow-up flush while busy."
(defun etaf--runtime-request-flush-now (runtime)
"Flush RUNTIME now, or mark one follow-up flush while busy."
(when (etaf-runtime-mounted-p runtime)
(if (or (> (etaf-runtime-event-depth runtime) 0)
(etaf-runtime-flushing-p runtime))
@ -5050,6 +5194,11 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(etaf--runtime-render-root-turn runtime t)))))
(setf (etaf-runtime-flushing-p runtime) nil))))))
(defun etaf--runtime-request-flush (runtime)
"Flush RUNTIME within one optional Runtime operation boundary."
(etaf--runtime-with-operation (runtime 'flush "reactive flush")
(etaf--runtime-request-flush-now runtime)))
;;;###autoload
(defun etaf-runtime-flush (&optional runtime)
"Flush mounted RUNTIME immediately and return its root Ebox node."
@ -5057,8 +5206,8 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(etaf--runtime-request-flush runtime)
(etaf-runtime-root-node runtime)))
(defun etaf--runtime-mount-now (buffer-or-name view)
"Mount VIEW into BUFFER-OR-NAME and return the live buffer."
(defun etaf--runtime-mount-now (buffer-or-name view observer)
"Mount VIEW with optional OBSERVER into BUFFER-OR-NAME."
(let* ((buffer (get-buffer-create buffer-or-name))
(old (gethash buffer etaf--runtime-table)))
(when old
@ -5087,6 +5236,7 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
:theme-paint-slots (make-hash-table :test #'eq)
:behaviors (make-hash-table :test #'equal)
:behavior-resource-keys (make-hash-table :test #'equal)
:observer observer
:root-dirty-p t)))
(puthash buffer runtime etaf--runtime-table)
(let ((route (etaf-runtime-route-create
@ -5097,25 +5247,28 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(puthash (etaf-runtime-mount-epoch runtime) runtime
etaf--runtime-route-registry))
(condition-case err
(progn
(etaf--runtime-with-operation
(runtime 'mount
(format "mount %s" (buffer-name buffer)))
(etaf--runtime-begin-candidate runtime)
(setf (etaf-runtime-flushing-p runtime) t
(etaf-runtime-root-view-cache runtime)
(etaf--runtime-evaluate-root-candidate runtime))
(unwind-protect
(etaf--runtime-render-effect runtime)
(setf (etaf-runtime-flushing-p runtime) nil)))
(setf (etaf-runtime-flushing-p runtime) nil))
(when (etaf-runtime-pending-p runtime)
(setf (etaf-runtime-pending-p runtime) nil)
(etaf--runtime-request-flush runtime))
(when (fboundp 'etaf-events-enable-input)
(etaf-events-enable-input buffer))
buffer)
((error quit)
(remhash buffer etaf--runtime-table)
(remhash (etaf-runtime-mount-epoch runtime)
etaf--runtime-route-registry)
(etaf-scope-stop scope)
(signal (car err) (cdr err))))
(when (etaf-runtime-pending-p runtime)
(setf (etaf-runtime-pending-p runtime) nil)
(etaf--runtime-request-flush runtime))
(when (fboundp 'etaf-events-enable-input)
(etaf-events-enable-input buffer))
buffer)))
(defun etaf--runtime-validate-mount-options (options)
@ -5126,7 +5279,7 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(unless tail
(error "ETAF mount option %S has no value" key))
(pop tail)
(unless (memq key '(:viewport-width :viewport-height))
(unless (memq key '(:viewport-width :viewport-height :observer))
(error "Unknown ETAF mount option: %S" key)))))
(when-let* ((width (plist-get options :viewport-width)))
(unless (and (numberp width) (> width 0))
@ -5134,6 +5287,11 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
(when-let* ((height (plist-get options :viewport-height)))
(unless (and (numberp height) (> height 0))
(error "ETAF mount :viewport-height must be positive: %S" height)))
(when (and (plist-member options :observer)
(not (or (null (plist-get options :observer))
(functionp (plist-get options :observer)))))
(signal 'wrong-type-argument
(list 'functionp (plist-get options :observer))))
options)
;;;###autoload
@ -5141,18 +5299,18 @@ backend anchor proof failed; ordinary root turns keep their artifact reuse."
"Mount VIEW into BUFFER-OR-NAME and return the live buffer.
Setup, reactive publication, Ebox rendering, and lifecycle work share one
framework render-burst allocation budget when the installed Ebox supports it.
OPTIONS may provide `:viewport-width' in pixels and `:viewport-height' in
lines, allowing the first publication to use its final layout context instead
of requiring an immediate viewport rerender."
OPTIONS may provide `:viewport-width' in pixels, `:viewport-height' in lines,
and `:observer' as a one-argument flat-report sink. The observer is installed
before the first Ebox publication."
(setq options (etaf--runtime-validate-mount-options options))
(let ((ebox-viewport-width (plist-get options :viewport-width))
(ebox-viewport-height (plist-get options :viewport-height)))
(ebox-call-with-render-burst
#'etaf--runtime-mount-now buffer-or-name view)))
#'etaf--runtime-mount-now buffer-or-name view
(plist-get options :observer))))
;;;###autoload
(defun etaf-runtime-unmount (&optional runtime)
"Unmount RUNTIME and dispose its Component scopes."
(defun etaf--runtime-unmount-now (runtime)
"Unmount RUNTIME and dispose its Component scopes now."
(let ((runtime (etaf-runtime-require-mounted runtime)))
(setf (etaf-runtime-mounted-p runtime) nil)
(when (fboundp 'etaf-events-disable-input)
@ -5184,6 +5342,24 @@ of requiring an immediate viewport rerender."
(clrhash (etaf-runtime-resource-registry runtime))
runtime))
;;;###autoload
(defun etaf-runtime-unmount (&optional runtime)
"Unmount RUNTIME, report the operation, and detach its observer."
(let* ((runtime (etaf-runtime-require-mounted runtime))
(observer (etaf-runtime-observer runtime))
(buffer (etaf-runtime-buffer runtime)))
(unwind-protect
(etaf--runtime-with-operation (runtime 'unmount "unmount")
(etaf--runtime-unmount-now runtime))
(when observer
(condition-case condition
(when (buffer-live-p buffer)
(ebox-buffer-set-observer buffer nil))
((error quit)
(etaf--runtime-record-observer-diagnostic
runtime (list :kind 'detach-failure :condition condition))))
(setf (etaf-runtime-observer runtime) nil)))))
;;;###autoload
(defun etaf-unmount (&optional runtime)
"Unmount RUNTIME, defaulting to the active or `current-buffer' Runtime."

2
etaf.el
View File

@ -31,6 +31,7 @@
(require 'etaf-compiler)
(require 'etaf-component)
(require 'etaf-reactive)
(require 'etaf-observer)
(require 'etaf-context)
(require 'etaf-resource)
(require 'etaf-data)
@ -40,7 +41,6 @@
(require 'etaf-behavior)
(require 'etaf-actions)
(require 'etaf-events)
(require 'etaf-performance)
(unless (fboundp 'ebox-call-with-render-burst)
(error "ETAF requires an Ebox build with framework render-burst support"))

91
tests/etaf-data-tests.el
View File

@ -6,6 +6,7 @@
(require 'ert)
(require 'etaf-data)
(require 'etaf-observer)
(defconst etaf-data-test-records
'((:id 1 :name "Ada" :group "compiler")
@ -325,4 +326,94 @@
(should-error (etaf-data-set-page controller 2)
:type 'etaf-data-stopped-error)))
(ert-deftest etaf-data-observes-source-capabilities-once-in-call-order ()
"Report source load and mutation without timing controller publication."
(let* ((source (etaf-data-memory-source '((:id 1)) :id-key :id))
(controller (etaf-data-controller source))
reports
diagnostics
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 41
:runtime-id 7
:buffer-name nil
:diagnostic (lambda (diagnostic) (push diagnostic diagnostics)))))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(etaf-data-load controller)
(etaf-data-mutate controller 'insert '(:id 2))))
(setq reports (nreverse reports))
(should-not diagnostics)
(should (equal '(load mutate load)
(mapcar (lambda (report)
(plist-get report :stage))
reports)))
(should (equal '(memory memory memory)
(mapcar (lambda (report)
(plist-get report :provider))
reports)))
(should (equal '(1 nil 1)
(mapcar (lambda (report)
(plist-get report :page))
reports)))
(should (eq 'insert (plist-get (cadr reports) :operation)))
(should (equal '((:id 1) (:id 2))
(etaf-value (etaf-data-items controller))))
(should (eq 'success (etaf-value
(etaf-data-status controller)))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-observed-source-error-preserves-controller-state ()
"Report a source error and preserve the ordinary Data error contract."
(let* ((source (etaf-data-source
:load (lambda (&rest _args) (error "unavailable"))))
(controller (etaf-data-controller source))
reports
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 42
:runtime-id 7
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(should-error
(etaf--observer-call-with-context
context (lambda () (etaf-data-load controller)))
:type 'error)
(should (= 1 (length reports)))
(should (eq 'data (plist-get (car reports) :provider)))
(should (eq 'load (plist-get (car reports) :stage)))
(should (eq 'error (plist-get (car reports) :status)))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (string-match-p
"unavailable"
(cadr (etaf-value (etaf-data-error controller))))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-source-rejects-invalid-observation-provider ()
"Require an explicit source provider to be a non-nil symbol."
(should-error
(etaf-data-source :provider nil
:load (lambda (&rest _args) (list :items nil)))
:type 'wrong-type-argument)
(should-error
(etaf-data-source :provider 7
:load (lambda (&rest _args) (list :items nil)))
:type 'wrong-type-argument))
(ert-deftest etaf-data-unobserved-source-call-bypasses-stage-runtime ()
"Keep the standalone source path free of observation work."
(let ((source (etaf-data-memory-source '((:id 1)) :id-key :id)))
(cl-letf (((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _args)
(ert-fail "unobserved Data call entered stage runtime"))))
(should (equal '((:id 1))
(plist-get (etaf-data-source-load-page source) :items))))))
;;; etaf-data-tests.el ends here

168
tests/etaf-observer-tests.el Normal file
View File

@ -0,0 +1,168 @@
;;; etaf-observer-tests.el --- Scoped observer port tests -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Tests for the dynamically scoped ETAF observer port.
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'etaf-observer)
(defun etaf-test-observer-context (sink &optional diagnostic)
"Return a test observer context using SINK and DIAGNOSTIC."
(etaf--observer-context-create
:sink sink
:operation-id 41
:runtime-id 9
:buffer-name "*etaf-test*"
:diagnostic (or diagnostic #'ignore)))
(ert-deftest etaf-observer-stage-preserves-success-and-metadata ()
"Observed stages preserve results and emit required flat metadata."
(let (reports)
(should
(eq 'result
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (report) (push report reports)))
(lambda ()
(etaf-observer-with-stage ('etaf 'render :detail "root")
'result)))))
(let ((report (car reports)))
(should (= 1 (length reports)))
(should (= etaf-observer-report-format-version
(plist-get report :format-version)))
(should (eq 'etaf (plist-get report :provider)))
(should (eq 'render (plist-get report :stage)))
(should (= 41 (plist-get report :operation-id)))
(should (= 1 (plist-get report :sequence)))
(should (= 9 (plist-get report :runtime-id)))
(should (equal "*etaf-test*" (plist-get report :buffer-name)))
(should (eq 'success (plist-get report :status)))
(should (equal "root" (plist-get report :detail)))
(should (>= (plist-get report :duration-ms) 0.0)))))
(ert-deftest etaf-observer-stage-preserves-error-and-quit ()
"Observed failures are reported and re-signaled without translation."
(let (reports error-condition quit-condition)
(let ((context
(etaf-test-observer-context
(lambda (report) (push report reports)))))
(setq error-condition
(condition-case condition
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-with-stage ('etaf 'render)
(signal 'wrong-type-argument '(integerp bad)))))
(error condition)))
(setq quit-condition
(condition-case condition
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-with-stage ('ebox 'commit)
(signal 'quit '(requested)))))
(quit condition))))
(should (equal '(wrong-type-argument integerp bad) error-condition))
(should (equal '(quit requested) quit-condition))
(setq reports (nreverse reports))
(should (equal '(error quit)
(mapcar (lambda (report) (plist-get report :status))
reports)))
(should (equal '(1 2)
(mapcar (lambda (report) (plist-get report :sequence))
reports)))))
(ert-deftest etaf-observer-emits-defensive-flat-copy ()
"Observer mutation cannot alter the producer's report snapshot."
(let* ((detail (copy-sequence "producer"))
(report (list :provider 'ebox :stage 'commit
:status 'success :duration-ms 1.0
:detail (list detail)))
(original (copy-tree report)))
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (delivered)
(setcar delivered :mutated)
(setcar (cdr delivered) 99)
(aset (car (plist-get delivered :detail)) 0 ?!)))
(lambda () (etaf-observer-emit report)))
(should (equal original report))
(should (equal "producer" detail))))
(ert-deftest etaf-observer-contains-observer-failures-and-invalid-reports ()
"Observer and validation failures are diagnostics, not product failures."
(let (diagnostics failure)
(let ((context
(etaf-test-observer-context
(lambda (_report)
(if (eq failure 'error)
(error "Observer error")
(signal 'quit '(observer-quit))))
(lambda (diagnostic) (push diagnostic diagnostics)))))
(setq failure 'error)
(should
(eq 'product-result
(etaf--observer-call-with-context
context
(lambda ()
(prog1 'product-result
(etaf-observer-emit
'(:provider etaf :stage render
:status success :duration-ms 0.0)))))))
(setq failure 'quit)
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-emit
'(:provider etaf :stage commit
:status success :duration-ms 0.0))))
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-emit '(:provider etaf :nested (not flat))))))
(should (equal '(observer-failure observer-failure invalid-report)
(mapcar (lambda (diagnostic)
(plist-get diagnostic :kind))
(nreverse diagnostics))))))
(ert-deftest etaf-observer-clears-context-during-reentrant-delivery ()
"Observer reentry sees no active observation context."
(let (context-seen reports)
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (report)
(push report reports)
(setq context-seen etaf--observer-context)
(etaf-observer-with-stage ('etaf 'reentrant) 'ignored)))
(lambda ()
(etaf-observer-with-stage ('etaf 'outer) 'done)))
(should-not context-seen)
(should (= 1 (length reports)))
(should (eq 'outer (plist-get (car reports) :stage)))))
(ert-deftest etaf-observer-nil-path-does-zero-instrumentation ()
"The unobserved path does not time, allocate delivery, or inspect GC state."
(let ((body-count 0)
(etaf--observer-context nil))
(cl-letf (((symbol-function 'float-time)
(lambda (&optional _time) (error "Unexpected clock read")))
((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _arguments) (error "Unexpected stage wrapper")))
((symbol-function 'etaf-observer-emit)
(lambda (&rest _arguments) (error "Unexpected report"))))
(should
(eq 'plain-result
(etaf-observer-with-stage ('etaf 'render)
(setq body-count (1+ body-count))
'plain-result))))
(should (= 1 body-count))))
(provide 'etaf-observer-tests)
;;; etaf-observer-tests.el ends here

81
tests/etaf-resource-tests.el
View File

@ -5,6 +5,7 @@
;;; Code:
(require 'ert)
(require 'etaf-observer)
(require 'etaf-resource)
(ert-deftest etaf-resource-loads-synchronous-value ()
@ -108,4 +109,84 @@
(lambda (_condition) (error "handler")))
:type 'error))
(ert-deftest etaf-resource-observes-only-loader-execution ()
"Report Resource loads while preserving replacement cleanup semantics."
(let* ((loads 0)
(cleanups 0)
reports
resource
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 51
:runtime-id 8
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(setq resource
(etaf-resource
(lambda ()
(etaf-resource-result
(cl-incf loads)
:cleanup (lambda () (cl-incf cleanups))))))
(etaf-resource-load resource)))
(setq reports (nreverse reports))
(should (equal '(resource resource)
(mapcar (lambda (report)
(plist-get report :provider))
reports)))
(should (equal '(load load)
(mapcar (lambda (report)
(plist-get report :stage))
reports)))
(should (equal '(success success)
(mapcar (lambda (report)
(plist-get report :status))
reports)))
(should (= 2 (etaf-resource-value resource)))
(should (= 1 cleanups))
(etaf-resource-dispose resource)
(should (= 2 cleanups)))
(when resource
(etaf-resource-dispose resource)))))
(ert-deftest etaf-resource-observed-error-keeps-captured-error-contract ()
"Report loader failure without changing Resource error containment."
(let* (reports resource
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 52
:runtime-id 8
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(setq resource (etaf-resource (lambda () (error "boom"))))))
(should (= 1 (length reports)))
(should (eq 'error (plist-get (car reports) :status)))
(should (eq 'error (etaf-resource-status resource)))
(should (string-match-p "boom" (cadr (etaf-resource-error resource)))))
(when resource
(etaf-resource-dispose resource)))))
(ert-deftest etaf-resource-unobserved-load-bypasses-stage-runtime ()
"Keep standalone Resource loading free of observation work."
(let (resource)
(unwind-protect
(cl-letf (((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _args)
(ert-fail "unobserved Resource entered stage runtime"))))
(setq resource (etaf-resource (lambda () "ready")))
(should (equal "ready" (etaf-resource-value resource))))
(when resource
(etaf-resource-dispose resource)))))
;;; etaf-resource-tests.el ends here

124
tests/etaf-tests.el
View File

@ -2410,6 +2410,130 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-runtime-observer-covers-initial-publication ()
"Observed mount emits TP, Ebox, then one final ETAF operation report."
(let ((buffer-name " *etaf-observed-mount-test*") reports)
(unwind-protect
(progn
(etaf-mount
buffer-name (etaf-view (box "Observed"))
(list :observer
(lambda (report) (push report reports))))
(setq reports (nreverse reports))
(should (equal (mapcar (lambda (report)
(plist-get report :provider))
reports)
'(tp ebox etaf)))
(should (equal (mapcar (lambda (report)
(plist-get report :sequence))
reports)
'(1 2 3)))
(should (equal (delete-dups
(mapcar (lambda (report)
(plist-get report :operation-id))
reports))
'(1)))
(let ((final (car (last reports))))
(should (eq (plist-get final :stage) 'runtime-operation))
(should (eq (plist-get final :kind) 'mount))
(should (eq (plist-get final :status) 'success))
(should (= (plist-get final :generation-before) 0))
(should (= (plist-get final :generation-after) 1))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-runtime-set-observer runtime nil)
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-runtime-observer-flattens-nested-event-and-detaches ()
"Nested event/flush work shares one operation and detach stops reports."
(let ((buffer-name " *etaf-observed-event-test*") reports)
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view (etaf-test-event-batch-nested)))
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-runtime-set-observer
runtime (lambda (report) (push report reports)))
(etaf-dispatch-event
runtime 'event-batch-nested-outer 'press)
(setq reports (nreverse reports))
(should (equal (mapcar (lambda (report)
(plist-get report :provider))
reports)
'(tp ebox etaf)))
(should (= 1 (cl-count 'etaf reports
:key (lambda (report)
(plist-get report :provider)))))
(should (= 1 (length
(delete-dups
(mapcar (lambda (report)
(plist-get report :operation-id))
reports)))))
(should (equal "Outer Inner nested"
(etaf-test--buffer-text buffer-name)))
(should-not (etaf-runtime-set-observer runtime nil))
(setq reports nil)
(etaf-dispatch-event
runtime 'event-batch-nested-outer 'press)
(should-not reports)))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-runtime-observer-noop-and-failure-cannot-change-state ()
"No-op observation and observer errors preserve exact committed state."
(let ((buffer-name " *etaf-observed-noop-test*") reports)
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (etaf-test-event-batch-noop)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-generation runtime))
(before (with-current-buffer buffer-name (buffer-string))))
(etaf-runtime-set-observer
runtime
(lambda (report)
(push report reports)
(error "observer failure")))
(etaf-dispatch-event runtime 'event-batch-noop 'press)
(should (= generation (etaf-runtime-generation runtime)))
(should (equal-including-properties
before (with-current-buffer buffer-name (buffer-string))))
(should (= 1 (length reports)))
(should (eq (plist-get (car reports) :provider) 'etaf))
(should (cl-find 'observer
(etaf-runtime-diagnostics runtime)
:key (lambda (entry)
(plist-get entry :phase))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-runtime-set-observer runtime nil)
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-runtime-observer-compare-and-set-preserves-foreign-owner ()
"Observer consumers replace only the exact sink they own."
(let ((buffer-name " *etaf-observer-owner-test*")
(first #'ignore)
(second (lambda (_report) nil)))
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (box "Observer owner")))
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(should (etaf-runtime-compare-and-set-observer runtime nil first))
(should-not
(etaf-runtime-compare-and-set-observer runtime nil second))
(should (etaf-runtime-compare-and-set-observer runtime first second))
(should-not
(etaf-runtime-compare-and-set-observer runtime first nil))
(should (etaf-runtime-compare-and-set-observer runtime second nil))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-runtime-set-observer runtime nil)
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-pvec-put-many-preserves-values-and-shares-untouched-branches ()
"Batch persistent-vector updates match sequential puts and share untouched paths."
(let* ((untouched-id (* 31 (expt 2 30)))