🐛 Attribute deferred component failures to the executed action

Preserve the prior executed tuple when settlement fails before resolving
another action. Keep that origin in the generated runner's error report
so removing an unexecuted following tuple preserves the shrink signature.
Failures raised by the new action still name the current tuple.

Add a real passing control and corruption regressions for deferred and
immediate failures. Keep rejection of genuinely different shrink failures.
The deferred regression failed three assertions before the fix; all four
focused tests now pass 37 assertions without weakening their checks.
No extra settlement pass or production sync change is needed.

Validation: common JVM 2,014 tests / 33,192 assertions; common JS
1,950 / 31,767; frontend 1,751 / 13,976; backend 1,793 / 9,007;
exporter 16 / 40. Six properties pass 40 programs at seed 712 in
both common runtimes. Lint and format checks pass for all four modules.

AI-assisted-by: gpt-6
This commit is contained in:
alonso.torres 2026-10-29 12:59:45 +01:00
parent 59731e8d2c
commit 1a8013f2f6
2 changed files with 69 additions and 4 deletions

View File

@ -824,7 +824,15 @@
(defn step
[state tuple]
(let [[kind index] tuple
state (if (= kind :sync) state (settle-state state))
state (if (= kind :sync) state
(try (settle-state state)
(catch #?(:clj Throwable :cljs :default) cause
;; Settlement finishes the prior action before resolving this tuple.
(let [previous (some #(when (= :executed (:status %)) (:tuple %))
(rseq (:trace state)))]
(throw (ex-info (ex-message cause)
(merge {:failing-op previous} (ex-data cause))
cause))))))
{:keys [situation model]} state
{:keys [op trace opportunities library-id] :as resolved} (resolve-op situation model tuple)
phase (or (:phase state) :random)
@ -986,9 +994,9 @@
(catch #?(:clj Throwable :cljs :default) cause
(throw (ex-info (str (ex-message cause) "\nReplay: (cg/run " (pr-str program) ")"
"\nTrace: " (pr-str (:trace @progress)))
(assoc (ex-data cause) :program program :trace (:trace @progress)
:coverage (:coverage @progress)
:failing-op (:current @progress))
(merge {:failing-op (:current @progress)} (ex-data cause)
{:program program :trace (:trace @progress)
:coverage (:coverage @progress)})
cause)))))))
(defn check-program

View File

@ -29,6 +29,63 @@
(t/use-fixtures :each thi/test-fixture)
(t/deftest deferred-failures-name-the-executed-action-and-keep-the-shrink-signature
(let [short-program {:world [1 0] :ops [[:edit 0 0 1 1] [:update-main 0]]}
long-program (update short-program :ops conj [:style 0 3 1 1])
settle r/settle
corrupt (fn [situation]
(let [id ((n/main-head-of "random-0") situation)
main (tm/shape-by-id situation id)]
(if (= "#ff0000" (get-in main [:fills 0 :fill-color]))
(let [file (tm/file situation)
page (thf/current-page file)
ids (mapv (comp :id :shape)
(filter #(= (:component-id main) (get-in % [:shape :component-id]))
(cg/tree situation)))
changes (cls/generate-update-shapes
(pcb/empty-changes nil (:id page)) ids
#(assoc % :fills (ths/sample-fills-color :fill-color "#FFFFFF"))
(:objects page) {:ignore-touched true})]
(tm/with-file situation (thf/apply-changes file changes)))
situation)))
failure (fn [run]
(try (run) nil
(catch #?(:clj Exception :cljs js/Error) error
(select-keys (ex-data error) [:invariant :phase :failing-op :trace]))))
coverage (atom {})
signature (atom nil)]
(t/is (map? (cg/run long-program)) "The real program passes before corrupting settlement")
(with-redefs [r/settle (fn
([situation] (corrupt (settle situation (r/pending-components situation))))
([situation ids] (corrupt (settle situation ids))))]
(doseq [program [long-program short-program]]
(let [data (failure #(cg/run program))]
(t/is (= :I9 (:invariant data)))
(t/is (= :requested-update-main (:phase data)))
(t/is (= [:edit :update-main] (mapv :kind (:trace data))))
(t/is (= [:update-main 0] (:failing-op data)))))
(t/is (some? (failure #(cg/check-program long-program coverage signature))))
(t/is (= [:I9 nil :requested-update-main :update-main] @signature))
(t/is (some? (failure #(cg/check-program short-program coverage signature)))
"Removing an unexecuted tuple must preserve the failure"))
(with-redefs [n/change-property (fn [target _property _value] (n/reset target))]
(let [data (failure #(cg/run short-program))]
(t/is (= :I9 (:invariant data)))
(t/is (= :requested-scalar (:phase data)))
(t/is (= [:edit 0 0 1 1] (:failing-op data))))
(t/is (true? (cg/check-program short-program coverage signature))
"A genuinely different shrink failure remains rejected"))))
(t/deftest immediate-failures-name-the-action-being-executed
(let [program {:world [1 0] :ops [[:edit 0 0 1 1] [:update-main 0]]}
failure (with-redefs [n/update-main n/reset]
(try (cg/run program) nil
(catch #?(:clj Exception :cljs js/Error) error (ex-data error))))]
(t/is (= :I9 (:invariant failure)))
(t/is (= :requested-update-main (:phase failure)))
(t/is (= [:edit] (mapv :kind (:trace failure))))
(t/is (= [:update-main 0] (:failing-op failure)))))
(t/deftest update-main-intent-rejects-losing-the-copy-value-while-every-copy-agrees
(doseq [program [{:world [1 0] :ops [[:edit 0 0 1 1] [:update-main 0]]}
{:world [1 0 {:library true}] :ops [[:edit 0 0 1 2] [:update-main 0]]}