285 lines
11 KiB
EmacsLisp
285 lines
11 KiB
EmacsLisp
;;; etaf-interaction-contract-tests.el --- Interaction contract tests -*- lexical-binding: t; -*-
|
|
|
|
;; SPDX-License-Identifier: GPL-3.0-or-later
|
|
|
|
;;; Commentary:
|
|
|
|
;; Lock the M0b Action, Behavior, and local event composition contract.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'etaf)
|
|
|
|
(defun etaf-interaction-test--dispose-buffer (buffer-name)
|
|
"Unmount and kill BUFFER-NAME when either still exists."
|
|
(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-interaction-duplicate-behavior-fails-before-install ()
|
|
"Reject duplicate names on one Host without running either installer."
|
|
(let ((buffer-name " *etaf-duplicate-behavior-contract*")
|
|
(installs 0))
|
|
(unwind-protect
|
|
(let ((first
|
|
(etaf-behavior-create
|
|
'duplicate
|
|
:install (lambda () (cl-incf installs) #'ignore)))
|
|
(second
|
|
(etaf-behavior-create
|
|
'duplicate
|
|
:install (lambda () (cl-incf installs) #'ignore))))
|
|
(should-error
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text (list :ref 'target :use (list first second))
|
|
(list "target"))))
|
|
:type 'etaf-behavior-error)
|
|
(should (zerop installs)))
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-interaction-behaviors-compose-in-declaration-order ()
|
|
"Preserve installer/event order, first-wins props, and one cleanup each."
|
|
(let ((buffer-name " *etaf-behavior-order-contract*")
|
|
install-order event-order cleanup-counts)
|
|
(unwind-protect
|
|
(let* ((first
|
|
(etaf-behavior-create
|
|
'first
|
|
:class "first"
|
|
:on-press (lambda () (setq event-order
|
|
(append event-order '(first))))
|
|
:install (lambda ()
|
|
(setq install-order (append install-order '(first)))
|
|
(lambda () (push 'first cleanup-counts)))))
|
|
(second
|
|
(etaf-behavior-create
|
|
'second
|
|
:class "second"
|
|
:on-press (lambda () (setq event-order
|
|
(append event-order '(second))))
|
|
:install (lambda ()
|
|
(setq install-order (append install-order '(second)))
|
|
(lambda () (push 'second cleanup-counts))))))
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'target :use (list first second)
|
|
:on-press
|
|
(lambda () (setq event-order (append event-order '(host)))))
|
|
(list "target"))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
|
(should (equal install-order '(first second)))
|
|
(should (equal (plist-get
|
|
(etaf-runtime-host-props-for runtime 'target)
|
|
:class)
|
|
"first"))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (equal event-order '(host first second)))
|
|
(etaf-unmount runtime))
|
|
(should (= 1 (cl-count 'first cleanup-counts)))
|
|
(should (= 1 (cl-count 'second cleanup-counts))))
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-interaction-callback-failure-short-circuits-behaviors ()
|
|
"Stop Behavior callbacks after an earlier callback signals."
|
|
(let ((buffer-name " *etaf-behavior-failure-contract*") trace)
|
|
(unwind-protect
|
|
(let ((first
|
|
(etaf-behavior-create
|
|
'first :on-press
|
|
(lambda () (push 'first trace) (error "first failed"))))
|
|
(second
|
|
(etaf-behavior-create
|
|
'second :on-press (lambda () (push 'second trace)))))
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'target :use (list first second)
|
|
:on-press (lambda () (push 'host trace) (error "host failed")))
|
|
(list "target"))))
|
|
(should-error
|
|
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
|
'target 'press))
|
|
(should (equal trace '(host)))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
|
|
(setq trace nil)
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'target :use (list first second)
|
|
:on-press (lambda () (push 'host trace)))
|
|
(list "target"))))
|
|
(should-error
|
|
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
|
'target 'press))
|
|
(should (equal trace '(first host))))
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-interaction-stable-installer-identity-cleans-up-once ()
|
|
"Reuse an identical installer and run its cleanup exactly once."
|
|
(let ((buffer-name " *etaf-behavior-identity-contract*")
|
|
(trigger (etaf-ref 0))
|
|
(installs 0)
|
|
(cleanups 0))
|
|
(unwind-protect
|
|
(let* ((installer
|
|
(lambda ()
|
|
(cl-incf installs)
|
|
(lambda () (cl-incf cleanups))))
|
|
(behavior
|
|
(etaf-behavior-create 'stable :install installer)))
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'target :use behavior
|
|
:aria-label (format "version-%d" (etaf-value trigger)))
|
|
(list "target"))))
|
|
(should (= installs 1))
|
|
(setf (etaf-value trigger) 1)
|
|
(should (= installs 1))
|
|
(should (zerop cleanups))
|
|
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
|
|
(should (= cleanups 1)))
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-interaction-events-do-not-capture-or-bubble ()
|
|
"Dispatch only the callback owned by the exact Host reference."
|
|
(let ((buffer-name " *etaf-local-event-contract*") trace)
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'column
|
|
(list :ref 'parent :on-press (lambda () (push 'parent trace)))
|
|
(list
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'child :on-press (lambda () (push 'child trace)))
|
|
(list "child"))))))
|
|
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
|
(etaf-dispatch-event runtime 'child 'press)
|
|
(should (equal trace '(child)))
|
|
(setq trace nil)
|
|
(etaf-dispatch-event runtime 'parent 'press)
|
|
(should (equal trace '(parent)))))
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-action-duplicate-registration-errors-by-default ()
|
|
"Keep the first Action when another application claims the same name."
|
|
(let ((name 'etaf-interaction-test-cross-app-action)
|
|
(first (lambda (_runtime) 'first))
|
|
(second (lambda (_runtime) 'second)))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-action-register name first)
|
|
(should-error (etaf-action-register name second)
|
|
:type 'etaf-action-error)
|
|
(should (eq first
|
|
(etaf-action-spec-function
|
|
(gethash name etaf--action-registry)))))
|
|
(etaf-action-undefine name))))
|
|
|
|
(ert-deftest etaf-action-redefine-boundary-affects-only-future-dispatch ()
|
|
"Replace name lookup explicitly without flushing a mounted Runtime."
|
|
(let ((buffer-name " *etaf-action-redefine-contract*")
|
|
(name 'etaf-interaction-test-future-action)
|
|
(first-calls 0)
|
|
(second-calls 0))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-action-register
|
|
name (lambda (_runtime) (cl-incf first-calls)))
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf--view-call
|
|
'text
|
|
(list :ref 'target
|
|
:on-press (lambda () (etaf-dispatch name)))
|
|
(list "target"))))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
|
(generation (etaf-runtime-current-generation runtime)))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (= first-calls 1))
|
|
(etaf-action-redefine-run
|
|
(lambda ()
|
|
(etaf-action-register
|
|
name (lambda (_runtime) (cl-incf second-calls)))))
|
|
(should (eq generation
|
|
(etaf-runtime-current-generation runtime)))
|
|
(should (= first-calls 1))
|
|
(should (zerop second-calls))
|
|
(etaf-dispatch-event runtime 'target 'press)
|
|
(should (= second-calls 1))))
|
|
(etaf-action-undefine name)
|
|
(etaf-interaction-test--dispose-buffer buffer-name))))
|
|
|
|
(ert-deftest etaf-action-reload-requires-explicit-redefine-boundary ()
|
|
"Make repeated authoring definitions explicit and dynamically scoped."
|
|
(let ((name 'etaf-interaction-test-reload-action)
|
|
(function-symbol 'etaf-interaction-test-reload-action--etaf-action))
|
|
(unwind-protect
|
|
(progn
|
|
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
|
(_runtime)
|
|
'first)
|
|
t)
|
|
(should-error
|
|
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
|
(_runtime)
|
|
'unintended)
|
|
t)
|
|
:type 'etaf-action-error)
|
|
(should
|
|
(eq 'first
|
|
(funcall
|
|
(etaf-action-spec-function
|
|
(gethash name etaf--action-registry))
|
|
nil)))
|
|
(etaf-action-redefine-run
|
|
(lambda ()
|
|
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
|
(_runtime)
|
|
'second)
|
|
t)))
|
|
(should
|
|
(eq 'second
|
|
(funcall
|
|
(etaf-action-spec-function
|
|
(gethash name etaf--action-registry))
|
|
nil)))
|
|
(should-error
|
|
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
|
(_runtime)
|
|
'unintended)
|
|
t)
|
|
:type 'etaf-action-error)
|
|
(should
|
|
(eq 'second
|
|
(funcall
|
|
(etaf-action-spec-function
|
|
(gethash name etaf--action-registry))
|
|
nil))))
|
|
(etaf-action-undefine name)
|
|
(when (fboundp function-symbol)
|
|
(fmakunbound function-symbol)))))
|
|
|
|
(provide 'etaf-interaction-contract-tests)
|
|
|
|
;;; etaf-interaction-contract-tests.el ends here
|