diff --git a/Makefile b/Makefile index 7dd0000..fae5990 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/etaf-actions.el b/etaf-actions.el index f75d94b..6e6eb6d 100644 --- a/etaf-actions.el +++ b/etaf-actions.el @@ -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)))) - (let ((etaf--current-runtime runtime)) - (apply (etaf-action-spec-function spec) runtime arguments)))) + (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) diff --git a/etaf-data.el b/etaf-data.el index 8938025..498796f 100644 --- a/etaf-data.el +++ b/etaf-data.el @@ -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'." - (etaf-data--normalize-result - (funcall (etaf-data--source-function source :load t) - query (max 1 (or page 1)) (max 1 (or page-size 20))))) + (let ((page (max 1 (or page 1))) + (page-size (max 1 (or page-size 20)))) + (etaf-data--normalize-result + (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,11 +409,11 @@ 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-value (etaf-data--controller-query controller)) - (etaf-value (etaf-data--controller-page controller)) - (etaf-value (etaf-data--controller-page-size controller)))) + (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)))) (error (etaf-data--apply-error controller request-id err) (signal (car err) (cdr err)))))) @@ -408,9 +436,9 @@ 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) - operation payload))) + (etaf-data--source-mutate + (etaf-data--controller-source controller) + operation payload))) (etaf-data-load controller) result) (error diff --git a/etaf-events.el b/etaf-events.el index 3607594..db7c970 100644 --- a/etaf-events.el +++ b/etaf-events.el @@ -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) diff --git a/etaf-observer.el b/etaf-observer.el new file mode 100644 index 0000000..fb3057d --- /dev/null +++ b/etaf-observer.el @@ -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 diff --git a/etaf-resource.el b/etaf-resource.el index cf88f6e..a6cc21c 100644 --- a/etaf-resource.el +++ b/etaf-resource.el @@ -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-scope-run - (etaf-resource-scope resource) - (etaf-resource-loader resource))) + (etaf-observer-with-stage ('resource 'load) + (etaf-scope-run + (etaf-resource-scope resource) + (etaf-resource-loader resource)))) (error (setq error-data err))) (if error-data (etaf--resource-set-state resource 'error nil error-data) diff --git a/etaf-runtime.el b/etaf-runtime.el index 85f225f..3843396 100644 --- a/etaf-runtime.el +++ b/etaf-runtime.el @@ -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." diff --git a/etaf.el b/etaf.el index 9965cfc..fe55b23 100644 --- a/etaf.el +++ b/etaf.el @@ -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")) diff --git a/tests/etaf-data-tests.el b/tests/etaf-data-tests.el index 4bc45c5..4a52cc6 100644 --- a/tests/etaf-data-tests.el +++ b/tests/etaf-data-tests.el @@ -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 diff --git a/tests/etaf-observer-tests.el b/tests/etaf-observer-tests.el new file mode 100644 index 0000000..4ee1728 --- /dev/null +++ b/tests/etaf-observer-tests.el @@ -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 diff --git a/tests/etaf-resource-tests.el b/tests/etaf-resource-tests.el index 977e1af..a4523f7 100644 --- a/tests/etaf-resource-tests.el +++ b/tests/etaf-resource-tests.el @@ -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 diff --git a/tests/etaf-tests.el b/tests/etaf-tests.el index ce9d2ef..5d85f53 100644 --- a/tests/etaf-tests.el +++ b/tests/etaf-tests.el @@ -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)))