fix(runtime): preserve rollback custody and scheduler tails
This commit is contained in:
Kinneyzhang
parent
003799e1d6
commit
de622c263f
@ -127,9 +127,12 @@ Runtime, watchers run synchronously.")
|
||||
(etaf-runtime-route-active-p route)
|
||||
(let ((predicate (etaf-runtime-route-accepts-p route)))
|
||||
(or (null predicate)
|
||||
(condition-case nil
|
||||
(condition-case condition
|
||||
(funcall predicate route)
|
||||
((error quit) nil))))))
|
||||
((error quit)
|
||||
(etaf-scheduler-record-route-authority-fault
|
||||
(etaf--subscriber-scheduler-context route) condition)
|
||||
nil))))))
|
||||
|
||||
(defun etaf-reactive-enqueue-runtime-flush
|
||||
(runtime function &optional scheduler-context)
|
||||
@ -142,20 +145,27 @@ The default context preserves the legacy two-argument facade."
|
||||
(defun etaf--dispatch-subscriber-group
|
||||
(context source _projection-epoch subscribers)
|
||||
"Notify SOURCE SUBSCRIBERS already grouped for scheduler CONTEXT."
|
||||
(dolist (subscriber subscribers)
|
||||
(etaf-scheduler-record-subscriber-visit context)
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(if (etaf-runtime-route-live-p subscriber)
|
||||
(funcall (etaf-runtime-route-scheduler subscriber)
|
||||
subscriber source)
|
||||
(etaf-scheduler-record-stale-route-drop context)))
|
||||
((and (etaf-effect-p subscriber)
|
||||
(etaf-effect-active-p subscriber)
|
||||
(etaf-scheduler-claim-effect context subscriber))
|
||||
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
|
||||
(funcall scheduler subscriber)
|
||||
(etaf-reactive-effect-run subscriber))))))
|
||||
(let (first-condition)
|
||||
(dolist (subscriber subscribers)
|
||||
(etaf-scheduler-record-subscriber-visit context)
|
||||
(condition-case condition
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(if (etaf-runtime-route-live-p subscriber)
|
||||
(funcall (etaf-runtime-route-scheduler subscriber)
|
||||
subscriber source)
|
||||
(etaf-scheduler-record-stale-route-drop context)))
|
||||
((and (etaf-effect-p subscriber)
|
||||
(etaf-effect-active-p subscriber)
|
||||
(etaf-scheduler-claim-effect context subscriber))
|
||||
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
|
||||
(funcall scheduler subscriber)
|
||||
(etaf-reactive-effect-run subscriber))))
|
||||
((error quit)
|
||||
(unless first-condition
|
||||
(setq first-condition condition)))))
|
||||
(when first-condition
|
||||
(signal (car first-condition) (cdr first-condition)))))
|
||||
|
||||
(defun etaf--reactive-same-p (left right)
|
||||
"Return whether LEFT and RIGHT are equal under ETAF's shallow rule."
|
||||
|
||||
@ -286,39 +286,153 @@
|
||||
(widen)
|
||||
(list :contents (buffer-substring (point-min) (point-max))
|
||||
:point (point)
|
||||
:mark-marker (mark-marker)
|
||||
:mark-position (mark t)
|
||||
:mark-insertion-type
|
||||
(marker-insertion-type (mark-marker))
|
||||
:mark-active mark-active
|
||||
:narrowed-p narrowed-p
|
||||
:narrow-start start
|
||||
:narrow-end end
|
||||
:read-only buffer-read-only
|
||||
:modified-p (buffer-modified-p))))))
|
||||
:modified-p (buffer-modified-p)
|
||||
:undo-list buffer-undo-list
|
||||
:overlays
|
||||
(mapcar
|
||||
(lambda (overlay)
|
||||
(list :overlay overlay
|
||||
:start (overlay-start overlay)
|
||||
:end (overlay-end overlay)))
|
||||
(delete-dups
|
||||
(append (car (overlay-lists)) (cdr (overlay-lists))))))))))
|
||||
|
||||
(defun etaf-render-port--v1-restore-buffer (buffer snapshot)
|
||||
"Restore BUFFER exactly from a pre-render v1 SNAPSHOT."
|
||||
(defun etaf-render-port--v1-restore-buffer
|
||||
(buffer snapshot &optional restore-contents-p)
|
||||
"Restore BUFFER editor state from a pre-render v1 SNAPSHOT.
|
||||
When RESTORE-CONTENTS-P is non-nil, also re-materialize text as a last-resort
|
||||
fallback after change-group cancellation itself failed."
|
||||
(unless (buffer-live-p buffer)
|
||||
(error "Legacy Ebox target died during manual cleanup"))
|
||||
(with-current-buffer buffer
|
||||
(let ((inhibit-read-only t)
|
||||
(inhibit-modification-hooks t))
|
||||
(widen)
|
||||
(erase-buffer)
|
||||
(insert (plist-get snapshot :contents))
|
||||
(goto-char (min (point-max)
|
||||
(max (point-min) (plist-get snapshot :point))))
|
||||
(when restore-contents-p
|
||||
(let ((buffer-undo-list t))
|
||||
(erase-buffer)
|
||||
(insert (plist-get snapshot :contents))))
|
||||
(let* ((saved-overlays (plist-get snapshot :overlays))
|
||||
(saved-identities
|
||||
(mapcar (lambda (entry) (plist-get entry :overlay))
|
||||
saved-overlays)))
|
||||
(dolist
|
||||
(overlay
|
||||
(delete-dups
|
||||
(append (car (overlay-lists)) (cdr (overlay-lists)))))
|
||||
(unless (memq overlay saved-identities)
|
||||
(delete-overlay overlay)))
|
||||
(dolist (entry saved-overlays)
|
||||
(let ((overlay (plist-get entry :overlay)))
|
||||
(move-overlay overlay
|
||||
(plist-get entry :start)
|
||||
(plist-get entry :end)
|
||||
buffer))))
|
||||
(when (plist-get snapshot :narrowed-p)
|
||||
(narrow-to-region
|
||||
(min (point-max) (plist-get snapshot :narrow-start))
|
||||
(min (point-max) (plist-get snapshot :narrow-end))))
|
||||
(goto-char (min (point-max)
|
||||
(max (point-min) (plist-get snapshot :point))))
|
||||
(let ((mark-marker (plist-get snapshot :mark-marker)))
|
||||
(set-marker mark-marker (plist-get snapshot :mark-position) buffer)
|
||||
(set-marker-insertion-type
|
||||
mark-marker (plist-get snapshot :mark-insertion-type)))
|
||||
(setq mark-active (plist-get snapshot :mark-active))
|
||||
(setq buffer-read-only (plist-get snapshot :read-only))
|
||||
(set-buffer-modified-p (plist-get snapshot :modified-p))))
|
||||
(set-buffer-modified-p (plist-get snapshot :modified-p))
|
||||
(setq buffer-undo-list (plist-get snapshot :undo-list))))
|
||||
buffer)
|
||||
|
||||
(defun etaf-render-port--v1-cleanup-step (phase function)
|
||||
"Run v1 cleanup FUNCTION and return a diagnostic for failure at PHASE."
|
||||
(let ((inhibit-quit t) (quit-flag nil))
|
||||
(condition-case condition
|
||||
(progn (funcall function) nil)
|
||||
((error quit)
|
||||
(list :phase phase :condition (copy-tree condition))))))
|
||||
(defun etaf-render-port--v1-cleanup-failed-initial
|
||||
(buffer snapshot change-group change-group-active-p stage-entered
|
||||
observer framework-rollback)
|
||||
"Clean one failed legacy initial operation and return diagnostics.
|
||||
BUFFER and SNAPSHOT identify editor custody. CHANGE-GROUP-ACTIVE-P says
|
||||
whether CHANGE-GROUP still needs cancellation. STAGE-ENTERED controls the
|
||||
paired FRAMEWORK-ROLLBACK. OBSERVER is detached before Ebox unmount."
|
||||
(let (cancel-failed-p)
|
||||
(when (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(setq-local etaf-render-port--v1-cleanup-diagnostics nil)))
|
||||
(cl-labels
|
||||
((record
|
||||
(diagnostic)
|
||||
(when (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(setq-local
|
||||
etaf-render-port--v1-cleanup-diagnostics
|
||||
(append etaf-render-port--v1-cleanup-diagnostics
|
||||
(list diagnostic))))))
|
||||
(run-phase
|
||||
(entry)
|
||||
(let ((phase (nth 0 entry))
|
||||
(function (nth 1 entry))
|
||||
(failure-function (nth 2 entry))
|
||||
completed-p)
|
||||
(unwind-protect
|
||||
(let ((inhibit-quit t) (quit-flag nil))
|
||||
(condition-case condition
|
||||
(progn (funcall function) (setq completed-p t))
|
||||
((error quit)
|
||||
(setq completed-p t)
|
||||
(when failure-function (funcall failure-function))
|
||||
(record
|
||||
(list :phase phase
|
||||
:condition (copy-tree condition))))))
|
||||
(unless completed-p
|
||||
(when failure-function (funcall failure-function))
|
||||
(record (list :phase phase :nonlocal-exit t))))))
|
||||
(run-phases
|
||||
(entries)
|
||||
(when entries
|
||||
;; A cleanup callback may perform an arbitrary nonlocal exit.
|
||||
;; Nested unwind cleanup guarantees every later phase still runs.
|
||||
(unwind-protect
|
||||
(run-phase (car entries))
|
||||
(run-phases (cdr entries))))))
|
||||
(run-phases
|
||||
`((framework-rollback
|
||||
,(lambda ()
|
||||
(when stage-entered
|
||||
(funcall framework-rollback nil))))
|
||||
(observer-detach
|
||||
,(lambda ()
|
||||
(when (and observer (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-buffer-set-observer buffer nil))))
|
||||
(ebox-unmount
|
||||
,(lambda ()
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))))
|
||||
(revision-reset
|
||||
,(lambda ()
|
||||
(when (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(setq-local
|
||||
etaf-render-port--v1-committed-revision nil)))))
|
||||
(change-group-cancel
|
||||
,(lambda ()
|
||||
(when change-group-active-p
|
||||
(with-current-buffer buffer
|
||||
(cancel-change-group change-group))))
|
||||
,(lambda () (setq cancel-failed-p t)))
|
||||
(buffer-restore
|
||||
,(lambda ()
|
||||
(etaf-render-port--v1-restore-buffer
|
||||
buffer snapshot cancel-failed-p))))))
|
||||
(and (buffer-live-p buffer)
|
||||
(etaf-render-port-v1-cleanup-diagnostics buffer))))
|
||||
|
||||
(defun etaf-render-port--v1-record-revision (buffer revision)
|
||||
"Record committed v1 REVISION for BUFFER without postaccept failure."
|
||||
@ -350,60 +464,53 @@ through Ebox's legacy initial option."
|
||||
framework-stage framework-rollback)
|
||||
(let* ((buffer (get-buffer-create buffer))
|
||||
(snapshot (etaf-render-port--v1-buffer-snapshot buffer))
|
||||
(result
|
||||
(progn
|
||||
(when (ebox-surface-buffer-mounted-p buffer)
|
||||
(error "Legacy Ebox initial operation requires an unmounted buffer"))
|
||||
(with-current-buffer buffer
|
||||
(setq-local etaf-render-port--v1-cleanup-diagnostics nil
|
||||
etaf-render-port--v1-committed-revision nil))
|
||||
(ebox-render-to-buffer
|
||||
buffer input (and observer (list :observer observer)))))
|
||||
stage-entered)
|
||||
(condition-case primary
|
||||
(progn
|
||||
(setq stage-entered t)
|
||||
(funcall framework-stage nil)
|
||||
;; TP surfaces start at committed revision one. Legacy Ebox does
|
||||
;; not expose its surface handle, so ETAF owns this compatibility
|
||||
;; evidence and advances it from later update reports.
|
||||
(etaf-render-port--v1-record-revision buffer 1)
|
||||
result)
|
||||
((error quit)
|
||||
(when stage-entered
|
||||
(let (diagnostics)
|
||||
(dolist
|
||||
(entry
|
||||
`((framework-rollback
|
||||
,(lambda () (funcall framework-rollback nil)))
|
||||
(observer-detach
|
||||
,(lambda ()
|
||||
(when (and observer (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-buffer-set-observer buffer nil))))
|
||||
(ebox-unmount
|
||||
,(lambda ()
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))))
|
||||
(revision-reset
|
||||
,(lambda ()
|
||||
(when (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(setq-local
|
||||
etaf-render-port--v1-committed-revision nil)))))
|
||||
(buffer-restore
|
||||
,(lambda ()
|
||||
(etaf-render-port--v1-restore-buffer buffer snapshot)))))
|
||||
(when-let* ((diagnostic
|
||||
(etaf-render-port--v1-cleanup-step
|
||||
(car entry) (cadr entry))))
|
||||
(push diagnostic diagnostics)))
|
||||
(when (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(setq-local etaf-render-port--v1-cleanup-diagnostics
|
||||
(nreverse diagnostics))))))
|
||||
(signal (car primary) (cdr primary))))))
|
||||
(change-group (with-current-buffer buffer (prepare-change-group)))
|
||||
result stage-entered operation-started-p change-group-active-p
|
||||
cleanup-ran-p)
|
||||
(cl-labels
|
||||
((cleanup
|
||||
()
|
||||
(unless cleanup-ran-p
|
||||
(setq cleanup-ran-p t)
|
||||
(when operation-started-p
|
||||
(let ((active-p change-group-active-p))
|
||||
(setq change-group-active-p nil)
|
||||
(etaf-render-port--v1-cleanup-failed-initial
|
||||
buffer snapshot change-group active-p stage-entered
|
||||
observer framework-rollback))))))
|
||||
(unwind-protect
|
||||
(condition-case primary
|
||||
(progn
|
||||
(when (ebox-surface-buffer-mounted-p buffer)
|
||||
(error
|
||||
"Legacy Ebox initial operation requires an unmounted buffer"))
|
||||
(with-current-buffer buffer
|
||||
(setq-local etaf-render-port--v1-cleanup-diagnostics nil
|
||||
etaf-render-port--v1-committed-revision nil)
|
||||
(activate-change-group change-group)
|
||||
(setq operation-started-p t
|
||||
change-group-active-p t)
|
||||
(save-restriction
|
||||
(widen)
|
||||
(setq result
|
||||
(ebox-render-to-buffer
|
||||
buffer input
|
||||
(and observer (list :observer observer))))))
|
||||
(setq stage-entered t)
|
||||
(funcall framework-stage nil)
|
||||
(with-current-buffer buffer
|
||||
(accept-change-group change-group))
|
||||
(setq change-group-active-p nil)
|
||||
;; TP surfaces start at committed revision one. Legacy Ebox
|
||||
;; does not expose its surface handle, so ETAF owns this
|
||||
;; compatibility evidence and advances it from update reports.
|
||||
(etaf-render-port--v1-record-revision buffer 1)
|
||||
result)
|
||||
((error quit)
|
||||
(cleanup)
|
||||
(signal (car primary) (cdr primary))))
|
||||
(when change-group-active-p
|
||||
(cleanup))))))
|
||||
|
||||
(defun etaf-render-port--v1-update
|
||||
(buffer input framework-stage framework-rollback)
|
||||
@ -535,7 +642,7 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
|
||||
(etaf-render-port-revision-function
|
||||
etaf-render-port--selected-port)
|
||||
buffer)))
|
||||
(unless (and (integerp revision) (>= revision 0))
|
||||
(unless (and (integerp revision) (> revision 0))
|
||||
(error "Mounted Ebox surface has no committed revision: %S"
|
||||
revision))
|
||||
revision))))
|
||||
|
||||
@ -367,8 +367,9 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
|
||||
(max 0 (1- (etaf-scheduler-context-busy-depth context))))))
|
||||
|
||||
(defun etaf-scheduler--drain-context-sources (context projection-id)
|
||||
"Drain one snapshotted CONTEXT source turn for PROJECTION-ID."
|
||||
(let ((turn (etaf-scheduler-context-source-queue context)))
|
||||
"Drain one CONTEXT source turn and return its first condition.
|
||||
PROJECTION-ID identifies the bounded projection owning the detached turn."
|
||||
(let ((turn (etaf-scheduler-context-source-queue context)) first-condition)
|
||||
;; New sources discovered by TURN belong to the next bounded scheduler
|
||||
;; turn. Detaching the current FIFO prevents a chain of distinct source
|
||||
;; identities from monopolizing one unbudgeted drain.
|
||||
@ -387,7 +388,12 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
|
||||
(etaf-scheduler-context-delivered-source-set context))
|
||||
(cl-incf (etaf-scheduler-context-source-delivery-count context))
|
||||
(when delivery
|
||||
(funcall delivery context source projection-id))))))))
|
||||
(condition-case condition
|
||||
(funcall delivery context source projection-id)
|
||||
((error quit)
|
||||
(unless first-condition
|
||||
(setq first-condition condition)))))))))
|
||||
first-condition))
|
||||
|
||||
(defun etaf-scheduler--detach-runtime-turns (projection)
|
||||
"Detach and return PROJECTION's Runtime queues in context order."
|
||||
@ -420,18 +426,35 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
|
||||
(setq first-condition condition)))))))))
|
||||
first-condition))
|
||||
|
||||
(defun etaf-scheduler--record-fault (context projection-id condition)
|
||||
"Record CONTEXT failure CONDITION for PROJECTION-ID."
|
||||
(defun etaf-scheduler--record-fault
|
||||
(context projection-id condition &optional phase)
|
||||
"Record CONTEXT failure CONDITION for PROJECTION-ID and optional PHASE."
|
||||
(setf (etaf-scheduler-context-fault-state context) (copy-tree condition))
|
||||
(cl-incf (etaf-scheduler-context-projection-fault-count context))
|
||||
(push (list :projection-epoch projection-id
|
||||
:turn-id (etaf-scheduler-context-active-turn-id context)
|
||||
:condition (copy-tree condition))
|
||||
(push (append (list :projection-epoch projection-id
|
||||
:turn-id
|
||||
(etaf-scheduler-context-active-turn-id context))
|
||||
(and phase (list :phase phase))
|
||||
(list :condition (copy-tree condition)))
|
||||
(etaf-scheduler-context-diagnostics context))
|
||||
(when (> (length (etaf-scheduler-context-diagnostics context)) 64)
|
||||
(setcdr (nthcdr 63 (etaf-scheduler-context-diagnostics context)) nil))
|
||||
condition)
|
||||
|
||||
(defun etaf-scheduler-record-route-authority-fault (context condition)
|
||||
"Record contained Host route authority CONDITION in scheduler CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (consp condition)
|
||||
(signal 'wrong-type-argument (list 'consp condition)))
|
||||
(when etaf-scheduler--active-projection
|
||||
(etaf-scheduler--append-context etaf-scheduler--active-projection context))
|
||||
(etaf-scheduler--record-fault
|
||||
context
|
||||
(if etaf-scheduler--active-projection
|
||||
(etaf-scheduler--projection-id etaf-scheduler--active-projection)
|
||||
(etaf-scheduler-context-projection-epoch context))
|
||||
condition 'route-authority))
|
||||
|
||||
(defun etaf-scheduler--drain-projection (projection)
|
||||
"Drain PROJECTION source-first and re-signal its first context fault."
|
||||
(let ((projection-id (etaf-scheduler--projection-id projection))
|
||||
@ -456,8 +479,11 @@ DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
|
||||
(progn
|
||||
(etaf-scheduler--mark-turn
|
||||
context projection-id marked-contexts context-steps)
|
||||
(etaf-scheduler--drain-context-sources
|
||||
context projection-id))
|
||||
(when-let* ((source-condition
|
||||
(etaf-scheduler--drain-context-sources
|
||||
context projection-id)))
|
||||
(signal (car source-condition)
|
||||
(cdr source-condition))))
|
||||
((error quit)
|
||||
(puthash context t failed-contexts)
|
||||
(unless first-condition (setq first-condition condition))
|
||||
|
||||
@ -166,6 +166,186 @@
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-failure-restores-exact-editor-custody ()
|
||||
"Legacy stage rollback preserves Emacs-owned editor identities and undo."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-editor-custody*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
overlay left-marker right-marker snapshot captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer
|
||||
(buffer-enable-undo)
|
||||
(insert (propertize "sentinel" 'face 'bold))
|
||||
(undo-boundary)
|
||||
(goto-char 4)
|
||||
(set-mark 2)
|
||||
(setq mark-active t)
|
||||
(setq overlay (make-overlay 2 6 buffer t t)
|
||||
left-marker (copy-marker 3 nil)
|
||||
right-marker (copy-marker 5 t))
|
||||
(overlay-put overlay 'etaf-test-property '(owned value))
|
||||
(narrow-to-region 2 7)
|
||||
(set-buffer-modified-p nil)
|
||||
(setq snapshot
|
||||
(list
|
||||
:contents
|
||||
(save-restriction
|
||||
(widen)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
:point (point)
|
||||
:mark-marker (mark-marker)
|
||||
:mark-position (mark t)
|
||||
:mark-insertion-type
|
||||
(marker-insertion-type (mark-marker))
|
||||
:mark-active mark-active
|
||||
:narrow-start (point-min)
|
||||
:narrow-end (point-max)
|
||||
:overlay-start (overlay-start overlay)
|
||||
:overlay-end (overlay-end overlay)
|
||||
:overlay-properties (overlay-properties overlay)
|
||||
:left-position (marker-position left-marker)
|
||||
:left-insertion-type (marker-insertion-type left-marker)
|
||||
:right-position (marker-position right-marker)
|
||||
:right-insertion-type (marker-insertion-type right-marker)
|
||||
:undo-list (copy-tree buffer-undo-list)
|
||||
:modified-p (buffer-modified-p))))
|
||||
(condition-case condition
|
||||
(etaf-render-port--v1-initial
|
||||
buffer input
|
||||
(lambda (_report) (error "editor custody primary"))
|
||||
#'ignore)
|
||||
(error (setq captured condition)))
|
||||
(should (equal captured '(error "editor custody primary")))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(with-current-buffer buffer
|
||||
(should
|
||||
(equal (save-restriction
|
||||
(widen)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
(plist-get snapshot :contents)))
|
||||
(should (= (point) (plist-get snapshot :point)))
|
||||
(should (eq (mark-marker) (plist-get snapshot :mark-marker)))
|
||||
(should (= (mark t) (plist-get snapshot :mark-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type (mark-marker))
|
||||
(plist-get snapshot :mark-insertion-type)))
|
||||
(should (eq mark-active (plist-get snapshot :mark-active)))
|
||||
(should (= (point-min) (plist-get snapshot :narrow-start)))
|
||||
(should (= (point-max) (plist-get snapshot :narrow-end)))
|
||||
(should (overlayp overlay))
|
||||
(should (eq (overlay-buffer overlay) buffer))
|
||||
(should (= (overlay-start overlay)
|
||||
(plist-get snapshot :overlay-start)))
|
||||
(should (= (overlay-end overlay)
|
||||
(plist-get snapshot :overlay-end)))
|
||||
(should (equal (overlay-properties overlay)
|
||||
(plist-get snapshot :overlay-properties)))
|
||||
(should (eq (marker-buffer left-marker) buffer))
|
||||
(should (= (marker-position left-marker)
|
||||
(plist-get snapshot :left-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type left-marker)
|
||||
(plist-get snapshot :left-insertion-type)))
|
||||
(should (eq (marker-buffer right-marker) buffer))
|
||||
(should (= (marker-position right-marker)
|
||||
(plist-get snapshot :right-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type right-marker)
|
||||
(plist-get snapshot :right-insertion-type)))
|
||||
(should (equal buffer-undo-list (plist-get snapshot :undo-list)))
|
||||
(should (eq (buffer-modified-p)
|
||||
(plist-get snapshot :modified-p)))))
|
||||
(when (overlayp overlay) (delete-overlay overlay))
|
||||
(when (markerp left-marker) (set-marker left-marker nil))
|
||||
(when (markerp right-marker) (set-marker right-marker nil))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-nonlocal-exit-runs-exact-cleanup ()
|
||||
"A legacy stage throw cannot escape with mounted or editor state retained."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-nonlocal-cleanup*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
(rollback-count 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "before"))
|
||||
(should
|
||||
(eq
|
||||
(catch 'etaf-v1-test-escape
|
||||
(etaf-render-port--v1-initial
|
||||
buffer input
|
||||
(lambda (_report)
|
||||
(throw 'etaf-v1-test-escape 'escaped))
|
||||
(lambda (_report) (cl-incf rollback-count)))
|
||||
'not-escaped)
|
||||
'escaped))
|
||||
(should (= rollback-count 1))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(should (equal "before"
|
||||
(with-current-buffer buffer (buffer-string))))
|
||||
(should-not
|
||||
(etaf-render-port-v1-cleanup-diagnostics buffer)))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-precondition-keeps-existing-mount ()
|
||||
"Rejecting an already mounted target must not clean up foreign authority."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-existing-mount*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ebox-render-to-buffer buffer (ebox-build '(box "existing")))
|
||||
(let ((revision (ebox-surface-buffer-revision buffer)))
|
||||
(should-error
|
||||
(etaf-render-port--v1-initial
|
||||
buffer (ebox-build '(box "replacement")) #'ignore #'ignore)
|
||||
:type 'error)
|
||||
(should (ebox-surface-buffer-mounted-p buffer))
|
||||
(should (= revision (ebox-surface-buffer-revision buffer)))
|
||||
(should (equal "existing"
|
||||
(with-current-buffer buffer (buffer-string))))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-rollback-throw-cannot-stop-cleanup-tail ()
|
||||
"A framework rollback throw still unmounts and restores legacy editor state."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-rollback-throw*"))
|
||||
(input (ebox-build '(box "committed"))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "before"))
|
||||
(should
|
||||
(eq
|
||||
(catch 'etaf-v1-rollback-escape
|
||||
(etaf-render-port--v1-initial
|
||||
buffer input
|
||||
(lambda (_report) (error "primary before rollback throw"))
|
||||
(lambda (_report)
|
||||
(throw 'etaf-v1-rollback-escape 'rollback-escaped)))
|
||||
'not-escaped)
|
||||
'rollback-escaped))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(should (equal "before"
|
||||
(with-current-buffer buffer (buffer-string))))
|
||||
(let ((diagnostic
|
||||
(cl-find 'framework-rollback
|
||||
(etaf-render-port-v1-cleanup-diagnostics buffer)
|
||||
:key (lambda (entry) (plist-get entry :phase)))))
|
||||
(should diagnostic)
|
||||
(should (plist-get diagnostic :nonlocal-exit))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v1-cleanup-fault-keeps-primary-and-continues ()
|
||||
"A secondary v1 cleanup fault is diagnosed while Ebox cleanup continues."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-cleanup-fault*"))
|
||||
@ -206,6 +386,9 @@
|
||||
(should (> (etaf-render-port-revision buffer) 0))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
|
||||
(lambda (_buffer) (error "injected report failure"))))
|
||||
(should-error (etaf-render-port-revision buffer) :type 'error))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
|
||||
(lambda (_buffer) 0)))
|
||||
(should-error (etaf-render-port-revision buffer) :type 'error)))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
|
||||
@ -266,6 +266,92 @@
|
||||
:runtime-executions)))
|
||||
(should (etaf-scheduler-context-idle-p context))))
|
||||
|
||||
(ert-deftest etaf-scheduler-source-fault-does-not-suppress-context-tail ()
|
||||
"A failing source delivery cannot discard later sources in the same turn."
|
||||
(let ((context (etaf-scheduler-context-create :name 'source-fault-tail))
|
||||
second-ran captured)
|
||||
(condition-case condition
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(etaf-scheduler-enqueue-source
|
||||
context 'first
|
||||
(lambda (_context _source _projection-id)
|
||||
(signal 'etaf-scheduler-test-source-condition '("first"))))
|
||||
(etaf-scheduler-enqueue-source
|
||||
context 'second
|
||||
(lambda (_context _source _projection-id)
|
||||
(setq second-ran t)))))
|
||||
(etaf-scheduler-test-source-condition (setq captured condition)))
|
||||
(should (equal captured
|
||||
'(etaf-scheduler-test-source-condition "first")))
|
||||
(should second-ran)
|
||||
(should (= 2 (etaf-scheduler-test--metric context :source-deliveries)))
|
||||
(should (etaf-scheduler-context-idle-p context))))
|
||||
|
||||
(ert-deftest etaf-scheduler-subscriber-fault-does-not-suppress-group-tail ()
|
||||
"A failing subscriber cannot discard later subscribers in the same source."
|
||||
(let* ((context
|
||||
(etaf-scheduler-context-create :name 'subscriber-fault-tail))
|
||||
second-ran
|
||||
(first
|
||||
(etaf-runtime-route-create
|
||||
:runtime-id 1 :mount-epoch 1 :authority-token 'first
|
||||
:scheduler-context context
|
||||
:scheduler
|
||||
(lambda (_route _source)
|
||||
(signal 'etaf-scheduler-test-source-condition
|
||||
'("subscriber")))))
|
||||
(second
|
||||
(etaf-runtime-route-create
|
||||
:runtime-id 2 :mount-epoch 1 :authority-token 'second
|
||||
:scheduler-context context
|
||||
:scheduler (lambda (_route _source) (setq second-ran t))))
|
||||
captured)
|
||||
(condition-case condition
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(etaf-scheduler-enqueue-source
|
||||
context 'source
|
||||
(lambda (delivery-context source projection-id)
|
||||
(etaf--dispatch-subscriber-group
|
||||
delivery-context source projection-id (list first second))))))
|
||||
(etaf-scheduler-test-source-condition (setq captured condition)))
|
||||
(should (equal captured
|
||||
'(etaf-scheduler-test-source-condition "subscriber")))
|
||||
(should second-ran)
|
||||
(should (= 2 (etaf-scheduler-test--metric context :subscriber-visits)))
|
||||
(should (etaf-scheduler-context-idle-p context))))
|
||||
|
||||
(ert-deftest etaf-scheduler-authority-predicate-fault-is-diagnostic ()
|
||||
"A broken Host authority predicate stays fail-closed and diagnostically visible."
|
||||
(let* ((context
|
||||
(etaf-scheduler-context-create :name 'authority-predicate-fault))
|
||||
(source (etaf-ref 0))
|
||||
scheduled
|
||||
(route
|
||||
(etaf-runtime-route-create
|
||||
:runtime-id 1 :mount-epoch 1 :authority-token 'authority
|
||||
:scheduler-context context
|
||||
:scheduler (lambda (_route _source) (setq scheduled t))
|
||||
:accepts-p
|
||||
(lambda (_route)
|
||||
(signal 'etaf-scheduler-test-condition '("authority"))))))
|
||||
(puthash route t (etaf-ref-subscribers source))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setf (etaf-value source) 1)
|
||||
(should-not scheduled)
|
||||
(should (= 1 (etaf-scheduler-test--metric
|
||||
context :stale-route-drops)))
|
||||
(let ((diagnostic
|
||||
(cl-find 'route-authority
|
||||
(etaf-scheduler-context-diagnostics context)
|
||||
:key (lambda (entry) (plist-get entry :phase)))))
|
||||
(should diagnostic)
|
||||
(should (equal (plist-get diagnostic :condition)
|
||||
'(etaf-scheduler-test-condition "authority")))))
|
||||
(remhash route (etaf-ref-subscribers source)))))
|
||||
|
||||
(ert-deftest etaf-scheduler-body-error-precedes-drain-error-and-quit-drains ()
|
||||
"Body failure wins over drain failure; quit still drains queued effects."
|
||||
(let* ((context (etaf-scheduler-context-create :name 'precedence))
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment)
|
||||
(:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment)
|
||||
(:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment)
|
||||
@ -32,4 +33,5 @@
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user