202 lines
8.7 KiB
EmacsLisp
202 lines
8.7 KiB
EmacsLisp
;;; etaf-m0a-current-characterization-tests.el --- M0a ETAF baseline -*- lexical-binding: t; -*-
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'etaf)
|
|
(require 'etaf-m0a-inventory)
|
|
|
|
(define-error 'etaf-test-m0a-lifecycle-condition
|
|
"M0a lifecycle characterization condition")
|
|
|
|
(defconst etaf-test-m0a-condition-data
|
|
'(:phase updated
|
|
:payload ((account-id . 42) (tags alpha beta))
|
|
:retryable nil)
|
|
"Non-trivial raw condition data used by the M0a public update probe.")
|
|
|
|
(etaf-define-component etaf-test-m0a-dependency-only (&key source)
|
|
"Observe SOURCE while retaining equal rendered output."
|
|
:view (text (expr (progn (etaf-value source) "same"))))
|
|
|
|
(etaf-define-component etaf-test-m0a-lifecycle-failure (&key label)
|
|
"Publish LABEL, then signal a custom condition from the update lifecycle."
|
|
:setup
|
|
(progn
|
|
(etaf-on-updated
|
|
(lambda ()
|
|
(signal 'etaf-test-m0a-lifecycle-condition
|
|
etaf-test-m0a-condition-data)))
|
|
nil)
|
|
:view (text (expr label)))
|
|
|
|
(ert-deftest etaf-m0a-action-registration-requires-explicit-redefinition ()
|
|
"Duplicate Action registration fails outside the authoring boundary."
|
|
(let* ((name (make-symbol "etaf-m0a-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-redefine-run
|
|
(lambda () (etaf-action-register name second)))
|
|
(should (eq second
|
|
(etaf-action-spec-function
|
|
(gethash name etaf--action-registry)))))
|
|
(etaf-action-undefine name))))
|
|
|
|
(ert-deftest etaf-m0a-event-kind-normalizes-current-spellings ()
|
|
"Keyword, symbol, and string event spellings normalize to one symbol."
|
|
(dolist (spelling '(:press press on-press "press" "on-press"))
|
|
(should (eq 'press (etaf-event-kind spelling)))))
|
|
|
|
(ert-deftest etaf-m0a-dependency-only-skips-ebox-and-tp-publication ()
|
|
"An equal-output dependency update advances ETAF only, not Ebox or TP."
|
|
(let ((buffer-name " *etaf-m0a-dependency-only*")
|
|
(source (etaf-ref 0))
|
|
(ebox-commits 0))
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer-name
|
|
(etaf-view (etaf-test-m0a-dependency-only :source source)))
|
|
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
|
(surface (with-current-buffer buffer-name
|
|
(car tp--buffer-surfaces)))
|
|
(generation (etaf-runtime-generation runtime))
|
|
(revision (tp-surface-revision surface))
|
|
(original-ebox-commit (symbol-function 'ebox-commit)))
|
|
(cl-letf (((symbol-function 'ebox-commit)
|
|
(lambda (&rest arguments)
|
|
(cl-incf ebox-commits)
|
|
(apply original-ebox-commit arguments))))
|
|
(setf (etaf-value source) 1))
|
|
(should (= (1+ generation) (etaf-runtime-generation runtime)))
|
|
(should (zerop ebox-commits))
|
|
(should (= revision (tp-surface-revision surface)))))
|
|
(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-m0a-repeated-public-unmount-signals-runtime-error ()
|
|
"Calling the public unmount boundary twice signals runtime error."
|
|
(let ((buffer-name " *etaf-m0a-repeated-unmount*") runtime)
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount buffer-name (etaf-view (text "mounted")))
|
|
(setq runtime (etaf-runtime-for-buffer buffer-name))
|
|
(etaf-unmount runtime)
|
|
(should-error (etaf-unmount runtime) :type 'etaf-runtime-error))
|
|
(when (and runtime (etaf-runtime-mounted-p runtime))
|
|
(etaf-unmount runtime))
|
|
(when-let* ((buffer (get-buffer buffer-name)))
|
|
(kill-buffer buffer)))))
|
|
|
|
(ert-deftest etaf-m0a-public-update-preserves-raw-condition-symbol-and-data ()
|
|
"A public update exposes the exact lifecycle condition symbol and payload."
|
|
(let ((buffer-name " *etaf-m0a-lifecycle-condition*")
|
|
(label (etaf-ref "A"))
|
|
captured)
|
|
(unwind-protect
|
|
(progn
|
|
(etaf-mount
|
|
buffer-name
|
|
(lambda ()
|
|
(etaf-view
|
|
(etaf-test-m0a-lifecycle-failure
|
|
:label (etaf-value label)))))
|
|
(condition-case condition
|
|
(setf (etaf-value label) "B")
|
|
(etaf-test-m0a-lifecycle-condition
|
|
(setq captured condition)))
|
|
(should
|
|
(equal captured
|
|
(cons 'etaf-test-m0a-lifecycle-condition
|
|
etaf-test-m0a-condition-data)))
|
|
(should (equal "B"
|
|
(with-current-buffer buffer-name
|
|
(buffer-string)))))
|
|
(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-m0a-condition-consumer-inventory-is-machine-readable ()
|
|
"The source consumer inventory exactly matches its reviewed golden."
|
|
(let ((consumers (etaf-m0a-condition-consumer-inventory))
|
|
(golden-file
|
|
(expand-file-name "tests/fixtures/etaf-m0a-condition-consumers.sexp"
|
|
etaf-m0a-package-root)))
|
|
(should consumers)
|
|
(should (cl-find "etaf-runtime.el" consumers
|
|
:key (lambda (entry) (plist-get entry :file))
|
|
:test #'equal))
|
|
(should (cl-every (lambda (entry)
|
|
(and (stringp (plist-get entry :file))
|
|
(integerp (plist-get entry :line))
|
|
(symbolp (plist-get entry :form))
|
|
(proper-list-p (plist-get entry :conditions))
|
|
(symbolp (plist-get entry :owner))
|
|
(memq (plist-get entry :policy)
|
|
'(generic-containment
|
|
specific-compatibility))))
|
|
consumers))
|
|
(with-temp-buffer
|
|
(insert-file-contents golden-file)
|
|
(should (equal (read (current-buffer))
|
|
(etaf-m0a-condition-consumer-signatures)))
|
|
(skip-chars-forward " \t\r\n")
|
|
(should (eobp)))
|
|
(should (cl-find 'observed-baseline
|
|
etaf-m0a-current-contract-inventory
|
|
:key (lambda (entry)
|
|
(plist-get entry :evidence-mode))))
|
|
(let ((json (json-parse-string (etaf-m0a-inventory-json))))
|
|
(should (= 1 (gethash "schema-version" json)))
|
|
(should (= (length etaf-m0a-current-contract-inventory)
|
|
(length (gethash "contract-inventory" json))))
|
|
(should (= (length consumers)
|
|
(length (gethash "condition-consumers" json))))
|
|
(should (= (length etaf-m0a-document-example-files)
|
|
(length (gethash "document-examples" json)))))))
|
|
|
|
(ert-deftest etaf-m0a-document-example-inventory-matches-reviewed-golden ()
|
|
"Every user documentation block matches its reviewed M0a outcome."
|
|
(let* ((golden-file
|
|
(expand-file-name "tests/fixtures/etaf-m0a-document-examples.sexp"
|
|
etaf-m0a-package-root))
|
|
(inventory (etaf-m0a-document-example-inventory))
|
|
(blocks (apply #'append
|
|
(mapcar (lambda (entry)
|
|
(plist-get entry :blocks))
|
|
inventory)))
|
|
golden)
|
|
(with-temp-buffer
|
|
(insert-file-contents golden-file)
|
|
(setq golden (read (current-buffer)))
|
|
(skip-chars-forward " \t\r\n")
|
|
(should (eobp)))
|
|
(should (equal golden (etaf-m0a-document-example-signatures)))
|
|
(should (= 122 (length blocks)))
|
|
(should (= 0 (cl-count 'read-error blocks
|
|
:key (lambda (entry)
|
|
(plist-get entry :drift)))))
|
|
(should (= 4 (cl-count 'macroexpand-error blocks
|
|
:key (lambda (entry)
|
|
(plist-get entry :drift)))))
|
|
(should (cl-every
|
|
(lambda (entry)
|
|
(and (eq 'skipped-unsafe (plist-get entry :load-status))
|
|
(eq 'arbitrary-document-code
|
|
(plist-get entry :load-reason))))
|
|
blocks))))
|
|
|
|
(provide 'etaf-m0a-current-characterization-tests)
|
|
;;; etaf-m0a-current-characterization-tests.el ends here
|