790 lines
35 KiB
EmacsLisp
790 lines
35 KiB
EmacsLisp
;;; etaf-event-forwarding-tests.el --- Composable Host interaction tests -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
;; Exercise fallthrough, committed disabled state, and interaction boundaries.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'etaf)
|
|
|
|
(defvar etaf-forward-test--trace nil)
|
|
(defvar etaf-forward-test--inner-use nil)
|
|
(defvar etaf-forward-test--middle-use nil)
|
|
(defvar etaf-forward-test--inner-disabled nil)
|
|
|
|
(defun etaf-forward-test--record (item)
|
|
"Append ITEM to the current interaction trace."
|
|
(setq etaf-forward-test--trace (append etaf-forward-test--trace (list item))))
|
|
|
|
(defun etaf-forward-test--dispose (buffer)
|
|
"Unmount and kill test BUFFER."
|
|
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf-unmount runtime))
|
|
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))
|
|
|
|
(etaf-define-component etaf-forward-test-leaf (&key on-press use disabled ref)
|
|
:view (text :ref ref :role 'button :tab-index 0 :disabled disabled
|
|
:on-press on-press :use use "Press"))
|
|
|
|
(etaf-define-component etaf-forward-test-middle ()
|
|
:view (etaf-forward-test-leaf
|
|
:ref 'internal
|
|
:disabled (if (etaf-ref-p etaf-forward-test--inner-disabled)
|
|
(etaf-value etaf-forward-test--inner-disabled)
|
|
etaf-forward-test--inner-disabled)
|
|
:use etaf-forward-test--inner-use
|
|
:on-press (lambda () (etaf-forward-test--record 'inner))))
|
|
|
|
(etaf-define-component etaf-forward-test-outer ()
|
|
:view (etaf-forward-test-middle
|
|
:use etaf-forward-test--middle-use
|
|
:on-press (lambda () (etaf-forward-test--record 'middle))))
|
|
|
|
(etaf-define-component etaf-forward-test-business (&key on-change)
|
|
:view (text :role 'checkbox :aria-checked nil
|
|
:on-press (let ((change on-change))
|
|
(lambda ()
|
|
(etaf-forward-test--record 'business)
|
|
(funcall change t)))
|
|
"Toggle"))
|
|
|
|
(etaf-define-component etaf-forward-test-layout (&key width classes use renders)
|
|
:render
|
|
(progn
|
|
(cl-incf (aref renders 0))
|
|
(if (eq use 'absent)
|
|
(etaf-view (box :ref 'layout :width (etaf-value width)
|
|
:class (etaf-value classes) (text "Text")))
|
|
(etaf-view (box :ref 'layout :width (etaf-value width)
|
|
:class (etaf-value classes) :use use (text "Text"))))))
|
|
|
|
(ert-deftest etaf-forward-behavior-keeps-host-property-dependencies-local ()
|
|
"Omitted, empty, and active `:use' preserve the same Host update boundary."
|
|
(let ((installs 0) (cleanups 0) installed-props)
|
|
(dolist (use (list 'absent nil (etaf-focusable)
|
|
(etaf-behavior-create
|
|
'layout-probe
|
|
:install
|
|
(lambda ()
|
|
(cl-incf installs)
|
|
(setq installed-props
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)))
|
|
(lambda () (cl-incf cleanups))))))
|
|
(let ((buffer (generate-new-buffer " *etaf-behavior-layout*"))
|
|
(width (etaf-ref 10))
|
|
(classes (etaf-ref '(first)))
|
|
(renders (vector 0)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer (etaf-node 'etaf-forward-test-layout
|
|
(list :width width :classes classes
|
|
:use use :renders renders) nil))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(should (equal renders [1]))
|
|
(setf (etaf-value width) 12)
|
|
(should (= 12 (plist-get (etaf-runtime-host-props-for runtime 'layout)
|
|
:width)))
|
|
(should (equal renders [1]))
|
|
(setf (etaf-value classes) '(second))
|
|
(should (equal '(second)
|
|
(plist-get (etaf-runtime-host-props-for runtime 'layout)
|
|
:class)))
|
|
(should (equal renders [1]))
|
|
(let ((generation (etaf-runtime-current-generation runtime)))
|
|
(cl-letf (((symbol-function 'etaf--runtime-swap-generation)
|
|
(lambda (&rest _) (error "Reject layout candidate"))))
|
|
(should-error (setf (etaf-value width) 14)))
|
|
(should (eq generation (etaf-runtime-current-generation runtime)))
|
|
(should (= 12 (plist-get (etaf-runtime-host-props-for runtime 'layout)
|
|
:width)))
|
|
(should (equal renders [1])))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
(should (= installs 1))
|
|
(should (= cleanups 1))
|
|
(should (= 10 (plist-get installed-props :width)))
|
|
(should (equal '(first) (plist-get installed-props :class)))
|
|
(should (eq 'layout (plist-get installed-props :ref)))))
|
|
|
|
(ert-deftest etaf-forward-declared-events-and-use-compose-once ()
|
|
"Consume declared callback/use props once through two root wrappers."
|
|
(let ((buffer " *etaf-forward-events*")
|
|
(etaf-forward-test--trace nil)
|
|
(etaf-forward-test--inner-use
|
|
(etaf-behavior-create
|
|
'inner :on-press (lambda () (etaf-forward-test--record 'behavior-inner))))
|
|
(etaf-forward-test--middle-use
|
|
(etaf-behavior-create
|
|
'middle :on-press (lambda () (etaf-forward-test--record 'behavior-middle)))))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(etaf-forward-test-outer
|
|
:ref 'target
|
|
:on-press (lambda () (etaf-forward-test--record 'outer))
|
|
:use (etaf-behavior-create
|
|
'outer :on-press
|
|
(lambda () (etaf-forward-test--record 'behavior-outer))))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (equal etaf-forward-test--trace
|
|
'(inner middle outer behavior-inner
|
|
behavior-middle behavior-outer)))
|
|
(should-not (etaf-runtime-handler-for runtime 'internal))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-disabled-or-recomputes-and-guards-public-input ()
|
|
"Outer nil never enables an internally disabled Host; later inputs recover."
|
|
(let* ((buffer " *etaf-forward-disabled*")
|
|
(outer-disabled (etaf-ref nil))
|
|
(inner-disabled (etaf-ref t))
|
|
(etaf-forward-test--inner-disabled inner-disabled)
|
|
(etaf-forward-test--trace nil))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(lambda ()
|
|
(etaf-view (etaf-forward-test-middle
|
|
:ref 'target :disabled (etaf-value outer-disabled)))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(should (plist-get (etaf-runtime-host-props-for runtime 'target)
|
|
:disabled))
|
|
(should-error (etaf-dispatch-event runtime 'target 'press)
|
|
:type 'etaf-event-error)
|
|
(should-error (etaf-focus runtime 'target) :type 'etaf-event-error)
|
|
(setf (etaf-value inner-disabled) nil)
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (equal etaf-forward-test--trace '(inner)))
|
|
(setf (etaf-value outer-disabled) t)
|
|
(should-error (etaf-dispatch-event runtime 'target 'press)
|
|
:type 'etaf-event-error)
|
|
(setf (etaf-value outer-disabled) nil)
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (equal etaf-forward-test--trace '(inner inner)))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-host-attribute-ownership ()
|
|
"Presentation defaults and caller labels coexist with owned role/state."
|
|
(let* ((root '(:color "red" :class "base" :role button :aria-checked nil
|
|
:tab-index 0 :aria-label "Default" :ref fallback))
|
|
(merged (etaf--merge-host-attrs
|
|
root '(:color nil :class (caller base) :tab-index 2
|
|
:aria-label "Caller" :ref target) 'text 'example)))
|
|
(should (equal "red" (plist-get merged :color)))
|
|
(should (equal '("base" "caller") (plist-get merged :class)))
|
|
(should (= 2 (plist-get merged :tab-index)))
|
|
(should (equal "Caller" (plist-get merged :aria-label)))
|
|
(should (eq 'target (plist-get merged :ref)))
|
|
(should-error (etaf--merge-host-attrs root '(:role navigation) 'text 'example)
|
|
:type 'etaf-component-call-error)
|
|
(should-error (etaf--merge-host-attrs root '(:aria-checked t) 'text 'example)
|
|
:type 'etaf-component-call-error)))
|
|
|
|
(ert-deftest etaf-forward-business-conversion-precedes-subscriptions ()
|
|
"A consumed change prop remains the business conversion for one press."
|
|
(let ((buffer " *etaf-forward-conversion*")
|
|
(etaf-forward-test--trace nil) (value nil))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(etaf-forward-test-business
|
|
:ref 'target
|
|
:on-change (lambda (next)
|
|
(setq value next)
|
|
(etaf-forward-test--record 'change))
|
|
:on-press (lambda () (etaf-forward-test--record 'outer))
|
|
:use (etaf-behavior-create
|
|
'observer :on-press
|
|
(lambda () (etaf-forward-test--record 'behavior))))))
|
|
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) 'target 'press)
|
|
(should value)
|
|
(should (equal etaf-forward-test--trace
|
|
'(business change outer behavior))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-wrapper-duplicate-behaviors-fail-before-install ()
|
|
"Do not lose duplicate names when declared use props consume fallthrough."
|
|
(let* ((buffer " *etaf-forward-duplicate-use*")
|
|
(installs 0)
|
|
(behavior (etaf-behavior-create
|
|
'duplicate :install (lambda () (cl-incf installs) nil)))
|
|
(etaf-forward-test--inner-use behavior))
|
|
(unwind-protect
|
|
(progn
|
|
(should-error
|
|
(etaf-mount buffer (etaf-view (etaf-forward-test-middle :use behavior)))
|
|
:type 'etaf-behavior-error)
|
|
(should (zerop installs)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-failed-callback-stops-outer-subscriptions ()
|
|
"An inner callback error stops outer subscriptions and Behaviors."
|
|
(let ((buffer " *etaf-forward-callback-failure*")
|
|
(etaf-forward-test--trace nil))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(etaf-forward-test-business
|
|
:ref 'target :on-change (lambda (_) (error "change failed"))
|
|
:on-press (lambda () (etaf-forward-test--record 'outer))
|
|
:use (etaf-behavior-create
|
|
'observer :on-press
|
|
(lambda () (etaf-forward-test--record 'behavior))))))
|
|
(should-error
|
|
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) 'target 'press))
|
|
(should (equal etaf-forward-test--trace '(business))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-behavior-final-props-precede-any-installer ()
|
|
"Installers receive final merged semantic props, after validation."
|
|
(let ((buffer " *etaf-forward-behavior-props*") (installs 0) (observed nil))
|
|
(unwind-protect
|
|
(let ((first
|
|
(etaf-behavior-create
|
|
'first :install
|
|
(lambda ()
|
|
(cl-incf installs)
|
|
(setq observed
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)))
|
|
nil))))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(text :ref 'target
|
|
:use (list first
|
|
(etaf-behavior-create 'label :aria-label "Final"))
|
|
"Target")))
|
|
(should (= installs 1))
|
|
(should (equal "Final" (plist-get observed :aria-label)))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(setq installs 0)
|
|
(should-error
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(text :ref 'target
|
|
:use (list first
|
|
(etaf-behavior-create 'invalid :disabled 'wrong))
|
|
"Target")))
|
|
:type 'etaf-renderer-error)
|
|
(should (zerop installs)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-disabled-behavior-never-installs ()
|
|
"Final disabled state, including Behavior defaults, precedes installation."
|
|
(let ((buffer " *etaf-forward-behavior-disabled*") (installs 0))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(text :ref 'target :disabled nil
|
|
:use (list
|
|
(etaf-behavior-create
|
|
'first :install (lambda () (cl-incf installs) nil))
|
|
(etaf-behavior-create 'disabled :disabled t))
|
|
"Disabled")))
|
|
(should (zerop installs))
|
|
(should (plist-get (etaf-runtime-host-props-for
|
|
(etaf-runtime-for-buffer buffer) 'target)
|
|
:disabled)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-behavior-disabled-transitions-and-rollback ()
|
|
"Commit disables clean up once; failed disables preserve the old resource."
|
|
(let ((buffer " *etaf-forward-behavior-transition*")
|
|
(mode (etaf-ref 'enabled))
|
|
(installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let ((behavior (etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
(etaf-mount
|
|
buffer
|
|
(lambda ()
|
|
(etaf-view
|
|
(column
|
|
(text :ref 'target :use behavior
|
|
:disabled (not (eq (etaf-value mode) 'enabled)) "Target")
|
|
(text (expr (if (eq (etaf-value mode) 'failed)
|
|
(error "later sibling failed") "OK")))))))
|
|
(should (= installs 1))
|
|
(should-error (setf (etaf-value mode) 'failed))
|
|
(should (= cleanups 0))
|
|
(should-not (plist-get (etaf-runtime-host-props-for
|
|
(etaf-runtime-for-buffer buffer) 'target)
|
|
:disabled))
|
|
(setf (etaf-value mode) 'disabled)
|
|
(should (= cleanups 1))
|
|
(setf (etaf-value mode) 'enabled)
|
|
(should (= installs 2))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-failed-enable-disposes-only-candidate-behavior ()
|
|
"A failed enable cleans its new resource while committed Host stays disabled."
|
|
(let ((buffer " *etaf-forward-enable-rollback*")
|
|
(mode (etaf-ref 'disabled)) (installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(column
|
|
(text :ref 'target :use behavior
|
|
:disabled (eq (etaf-value mode) 'disabled) "Target")
|
|
(text (expr (if (eq (etaf-value mode) 'failed)
|
|
(error "later sibling failed") "OK"))))))
|
|
(should (zerop installs))
|
|
(should-error (setf (etaf-value mode) 'failed))
|
|
(should (= installs 1))
|
|
(should (= cleanups 1))
|
|
(should (plist-get (etaf-runtime-host-props-for
|
|
(etaf-runtime-for-buffer buffer) 'target)
|
|
:disabled))
|
|
(setf (etaf-value mode) 'enabled)
|
|
(should (= installs 2))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-component-overlay-promotes-behavior-lifetime ()
|
|
"A locally enabled Component owns its installed Behavior through teardown."
|
|
(let ((buffer " *etaf-forward-overlay-behavior*")
|
|
(disabled (etaf-ref t)) (installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
;; Passing a View value keeps dependency ownership on the Component
|
|
;; input effect, exercising local overlay instead of Root rebuild.
|
|
(etaf-mount buffer
|
|
(etaf-view (etaf-forward-test-leaf
|
|
:ref 'target :use behavior
|
|
:disabled (etaf-value disabled))))
|
|
(should (zerop installs))
|
|
(setf (etaf-value disabled) nil)
|
|
(should (= installs 1))
|
|
(should (zerop cleanups))
|
|
(setf (etaf-value disabled) t)
|
|
(should (= cleanups 1))
|
|
(setf (etaf-value disabled) nil)
|
|
(should (= installs 2))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-root-fallback-releases-abandoned-behavior ()
|
|
"A local anchor proof miss releases candidate resources before Root retry."
|
|
(let ((buffer " *etaf-forward-fallback-behavior*")
|
|
(disabled (etaf-ref t)) (installs 0) (cleanups 0)
|
|
(miss-next t))
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(column
|
|
(etaf-forward-test-leaf :ref 'target :use behavior
|
|
:disabled (etaf-value disabled))
|
|
;; Read here to change this structural Range. A text child's
|
|
;; deferred Expr correctly owns its own independent update.
|
|
(expr (etaf-node
|
|
'text nil
|
|
(list (if (etaf-value disabled) "Disabled" "Enabled")))))))
|
|
(let ((original
|
|
(symbol-function 'etaf--runtime-range-change-has-backend-anchor-p)))
|
|
(cl-letf (((symbol-function 'etaf--runtime-range-change-has-backend-anchor-p)
|
|
(lambda (runtime change)
|
|
(if miss-next
|
|
(progn (setq miss-next nil) nil)
|
|
(funcall original runtime change)))))
|
|
(setf (etaf-value disabled) nil)))
|
|
(should-not miss-next)
|
|
(should (= installs 2))
|
|
(should (= cleanups 1))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-removed-component-retires-behavior-immediately ()
|
|
"A removed dynamic child releases its Behavior without waiting for unmount."
|
|
(let ((buffer " *etaf-forward-removed-behavior*")
|
|
(visible (etaf-ref t)) (installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view (column
|
|
(etaf-forward-test-leaf :if (etaf-value visible)
|
|
:ref 'target :use behavior))))
|
|
(should (= installs 1))
|
|
(setf (etaf-value visible) nil)
|
|
(should (= cleanups 1))
|
|
(should-not
|
|
(etaf--generation-index-entries
|
|
(etaf-runtime-current-generation (etaf-runtime-for-buffer buffer))
|
|
'behaviors))
|
|
(setf (etaf-value visible) t)
|
|
(should (= installs 2))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-component-overlay-removes-use-resources ()
|
|
"Changing or removing use retires obsolete names on a retained Host."
|
|
(let ((buffer " *etaf-forward-overlay-use*")
|
|
(use (etaf-ref nil)) (installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let* ((install (lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))
|
|
(first (etaf-behavior-create 'first :install install))
|
|
(second (etaf-behavior-create 'second :install install)))
|
|
(setf (etaf-value use) first)
|
|
(etaf-mount
|
|
buffer (etaf-view (etaf-forward-test-leaf
|
|
:ref 'target :use (etaf-value use))))
|
|
(should (= installs 1))
|
|
(setf (etaf-value use) second)
|
|
(should (= installs 2))
|
|
(should (= cleanups 1))
|
|
(setf (etaf-value use) nil)
|
|
(should (= cleanups 2))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 2)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-keyed-host-behaviors-follow-owner-through-reorder ()
|
|
"Keyed Host resources follow semantic owners through reorder and removal."
|
|
(let ((buffer " *etaf-forward-keyed-behavior*") active events)
|
|
(unwind-protect
|
|
(let* ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda ()
|
|
(let ((ref (plist-get
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)) :ref)))
|
|
(push ref active)
|
|
(push (list 'install ref) events)
|
|
(lambda ()
|
|
(setq active (delq ref active))
|
|
(push (list 'cleanup ref) events))))))
|
|
(a (etaf-node 'box (list :key 'a :ref 'a :use behavior) '("A")))
|
|
(b (etaf-node 'box (list :key 'b :ref 'b :use behavior) '("B")))
|
|
(items (etaf-ref (list a b))))
|
|
(etaf-mount buffer (etaf-view (column (expr (etaf-value items)))))
|
|
(setf (etaf-value items) (list b a))
|
|
(should (equal events '((install b) (install a))))
|
|
(setf (etaf-value items) (list b))
|
|
(should (equal active '(b)))
|
|
(should (equal events '((cleanup a) (install b) (install a))))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should-not active)
|
|
(should (= 1 (cl-count '(cleanup a) events :test #'equal)))
|
|
(should (= 1 (cl-count '(cleanup b) events :test #'equal))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-keyed-behavior-failure-retains-committed-owners ()
|
|
"Failed reorder/removal keeps committed resources and cleans only new ones."
|
|
(let ((buffer " *etaf-forward-keyed-behavior-rollback*") active events)
|
|
(unwind-protect
|
|
(let* ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda ()
|
|
(let ((ref (plist-get
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)) :ref)))
|
|
(push ref active)
|
|
(push (list 'install ref) events)
|
|
(lambda ()
|
|
(setq active (delq ref active))
|
|
(push (list 'cleanup ref) events))))))
|
|
(a (etaf-node 'box (list :key 'a :ref 'a :use behavior) '("A")))
|
|
(b (etaf-node 'box (list :key 'b :ref 'b :use behavior) '("B")))
|
|
(c (etaf-node 'box (list :key 'c :ref 'c :use behavior) '("C")))
|
|
(mode (etaf-ref 'initial)))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(column
|
|
(expr (pcase (etaf-value mode)
|
|
('initial (list a b))
|
|
('failed (list b c))
|
|
(_ (list b))))
|
|
(text (expr (if (eq (etaf-value mode) 'failed)
|
|
(error "later sibling failed") "OK"))))))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
|
(generation (etaf-runtime-current-generation runtime)))
|
|
(should-error (setf (etaf-value mode) 'failed))
|
|
(should (eq generation (etaf-runtime-current-generation runtime)))
|
|
(should (equal active '(b a)))
|
|
(should (equal events
|
|
'((cleanup c) (install c) (install b) (install a))))
|
|
(setf (etaf-value mode) 'removed)
|
|
(should (equal active '(b)))
|
|
(should (equal (car events) '(cleanup a)))
|
|
(etaf-unmount runtime)
|
|
(should-not active)
|
|
(dolist (ref '(a b c))
|
|
(should (= 1 (cl-count (list 'install ref) events :test #'equal)))
|
|
(should (= 1 (cl-count (list 'cleanup ref) events :test #'equal))))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-behavior-installer-receives-effective-host-ref ()
|
|
"An installer receives the effective address of an automatically referenced Host."
|
|
(let ((buffer " *etaf-forward-behavior-generated-ref*") installed-ref)
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(text :role 'button :on-press #'ignore
|
|
:use (etaf-behavior-create
|
|
'resource :install
|
|
(lambda ()
|
|
(setq installed-ref
|
|
(plist-get
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)) :ref))
|
|
nil))
|
|
"Control")))
|
|
(should installed-ref)
|
|
(should (etaf-runtime-handler-for
|
|
(etaf-runtime-for-buffer buffer) installed-ref)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-behavior-address-change-reinstalls-after-commit ()
|
|
"A retained Host changing its ref replaces the resource bound to that address."
|
|
(let ((buffer " *etaf-forward-behavior-ref-change*")
|
|
(ref (etaf-ref 'a)) active events)
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda ()
|
|
(let ((address (plist-get
|
|
(etaf-behavior-context-host-props
|
|
(etaf-current-behavior-context)) :ref)))
|
|
(push address active)
|
|
(push (list 'install address) events)
|
|
(lambda ()
|
|
(setq active (delq address active))
|
|
(push (list 'cleanup address) events)))))))
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view (box :key 'stable :ref (etaf-value ref) :use behavior "Host")))
|
|
(setf (etaf-value ref) 'b)
|
|
(should (equal active '(b)))
|
|
(should (equal events '((cleanup a) (install b) (install a))))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should-not active)
|
|
(should (equal (car events) '(cleanup b))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-carried-component-keeps-behavior-resource ()
|
|
"A Root update carrying an unchanged Component retains its Host resource."
|
|
(let ((buffer " *etaf-forward-carried-behavior*")
|
|
(version (etaf-ref 0)) (installs 0) (cleanups 0))
|
|
(unwind-protect
|
|
(let ((behavior
|
|
(etaf-behavior-create
|
|
'resource :install
|
|
(lambda () (cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))))
|
|
(etaf-mount
|
|
buffer
|
|
(lambda ()
|
|
(etaf-value version)
|
|
(etaf-view
|
|
(column
|
|
(etaf-forward-test-leaf :ref 'target :use behavior)))))
|
|
(should (= installs 1))
|
|
(setf (etaf-value version) 1)
|
|
(should (= installs 1))
|
|
(should (zerop cleanups))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
|
(should (= cleanups 1)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-callback-snapshot-changes-only-after-commit ()
|
|
"Composed subscriptions preserve committed scalar props after render fails."
|
|
(let ((buffer " *etaf-forward-callback-commit*")
|
|
(version (etaf-ref 'a)) (seen nil)
|
|
(etaf-forward-test--trace nil))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(column
|
|
(etaf-forward-test-middle
|
|
:ref 'target
|
|
:on-press (let ((snapshot (etaf-value version)))
|
|
(lambda () (push snapshot seen))))
|
|
(text (expr (if (eq (etaf-value version) 'failed)
|
|
(error "later sibling failed") "OK"))))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should-error (setf (etaf-value version) 'failed))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(setf (etaf-value version) 'b)
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (equal seen '(b a a)))
|
|
(should (equal etaf-forward-test--trace '(inner inner inner)))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-child-boundary-blocks-parent-activation ()
|
|
"A disabled or callbackless child owns its hit area, including equal bounds."
|
|
(let ((buffer " *etaf-forward-hit-boundary*") (trace nil))
|
|
(unwind-protect
|
|
(dolist (child-props '((:disabled t :on-press ignore) nil))
|
|
(etaf-mount
|
|
buffer
|
|
(lambda ()
|
|
(etaf-node
|
|
'box (list :ref 'aaa-parent :role 'row :tab-index 0
|
|
:on-press (lambda () (push 'parent trace)))
|
|
(list (etaf-node
|
|
'text (append '(:ref zzz-child :role button) child-props)
|
|
'("Child"))))))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
|
(position (etaf-host-ref-position runtime 'zzz-child)))
|
|
(should (equal (etaf-host-ref-bounds runtime 'aaa-parent)
|
|
(etaf-host-ref-bounds runtime 'zzz-child)))
|
|
(should-error (etaf--activation-at-position runtime position)
|
|
:type 'user-error)
|
|
(should-not trace)
|
|
(etaf-focus runtime 'aaa-parent)
|
|
(etaf-activate runtime)
|
|
(should (equal trace '(parent)))
|
|
(setq trace nil)
|
|
(etaf-unmount runtime)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-child-wins-and-ordinary-text-belongs-to-parent ()
|
|
"Semantic descendants beat equal bounds; passive text keeps row activation."
|
|
(let ((buffer " *etaf-forward-hit-order*") (trace nil))
|
|
(unwind-protect
|
|
(dolist (interactive '(t nil))
|
|
(etaf-mount
|
|
buffer
|
|
(lambda ()
|
|
(etaf-node
|
|
'box (list :ref 'aaa-parent
|
|
:on-press (lambda () (push 'parent trace)))
|
|
(list (etaf-node
|
|
'text (append '(:ref zzz-child)
|
|
(when interactive
|
|
(list :role 'button :on-press
|
|
(lambda () (push 'child trace)))))
|
|
'("Child"))))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf--activation-at-position
|
|
runtime (etaf-host-ref-position runtime 'zzz-child))
|
|
(should (equal trace (if interactive '(child) '(parent))))
|
|
(setq trace nil)
|
|
(etaf-unmount runtime)))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-focused-control-follows-changing-layout ()
|
|
"Repeated keyboard activation follows a retained control after width changes."
|
|
(let ((buffer " *etaf-forward-focus-layout*") (page (etaf-ref 9)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(row
|
|
(text (expr (format "Page %s" (etaf-value page))))
|
|
(text :ref 'next :role 'button :tab-index 0
|
|
:on-press (lambda () (cl-incf (etaf-value page))) "Next"))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf-focus runtime 'next)
|
|
(etaf-activate runtime)
|
|
(should (= (etaf-value page) 10))
|
|
(should (eq (etaf-focused-host-ref runtime) 'next))
|
|
(with-current-buffer buffer
|
|
(should (= (point) (etaf-host-ref-position runtime 'next))))
|
|
(etaf-activate runtime)
|
|
(should (= (etaf-value page) 11))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-layout-update-respects-manually-moved-point ()
|
|
"A layout commit must not pull point back after the user leaves a control."
|
|
(let ((buffer " *etaf-forward-focus-manual*") (page (etaf-ref 9)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(row
|
|
(text (expr (format "Page %s" (etaf-value page))))
|
|
(text :ref 'next :role 'button :tab-index 0 "Next"))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
|
(etaf-focus runtime 'next)
|
|
(with-current-buffer buffer (goto-char (point-min)))
|
|
(setf (etaf-value page) 10)
|
|
(with-current-buffer buffer
|
|
(should (= (point) (point-min)))
|
|
(should-not (= (point) (etaf-host-ref-position runtime 'next))))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(ert-deftest etaf-forward-focused-point-survives-failed-publication ()
|
|
"A failed candidate retains the old focus and point; the next commit follows."
|
|
(let ((buffer " *etaf-forward-focus-rollback*") (page (etaf-ref 9)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer
|
|
(etaf-view
|
|
(row
|
|
(text (expr (format "Page %s" (etaf-value page))))
|
|
(text :ref 'next :role 'button :tab-index 0 "Next")
|
|
(text (expr (if (= (etaf-value page) 10)
|
|
(error "later rendering failed") "OK"))))))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
|
(generation (etaf-runtime-current-generation runtime))
|
|
(position (etaf-host-ref-position runtime 'next)))
|
|
(etaf-focus runtime 'next)
|
|
(should-error (setf (etaf-value page) 10))
|
|
(should (eq generation (etaf-runtime-current-generation runtime)))
|
|
(should (eq (etaf-focused-host-ref runtime) 'next))
|
|
(with-current-buffer buffer (should (= (point) position)))
|
|
(setf (etaf-value page) 11)
|
|
(with-current-buffer buffer
|
|
(should (= (point) (etaf-host-ref-position runtime 'next))))))
|
|
(etaf-forward-test--dispose buffer))))
|
|
|
|
(provide 'etaf-event-forwarding-tests)
|
|
;;; etaf-event-forwarding-tests.el ends here
|