From 59731e8d2c10c72f8a9ad19f6f40eba1ed78b6c6 Mon Sep 17 00:00:00 2001 From: "alonso.torres" Date: Thu, 29 Oct 2026 11:54:01 +0100 Subject: [PATCH] :bug: Check update-main intent in the component oracle Check authored values against the copy before update-main clears its overrides. Verify scalar and text values, grid membership and component choice in the destination main. Use before-state geometry ownership and the existing tolerances. Retain intent through deferred synchronization, including explicit sync, and check the completed result before dropping that temporary context. Add real and corrupt controls for local and linked libraries, scalar inputs, text units, geometry and the frontend replay pipeline. Validation: common JVM 2,012 tests / 33,188 assertions; common JS 1,948 / 31,799; 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 --- .../common/test_helpers/composable/gen.cljc | 18 +++- .../test_helpers/composable/oracle.cljc | 98 +++++++++++++++---- .../logic/composable_gen_test.cljc | 65 ++++++++++++ .../composable_tests/generated_test.cljs | 56 ++++++++++- 4 files changed, 214 insertions(+), 23 deletions(-) diff --git a/common/src/app/common/test_helpers/composable/gen.cljc b/common/src/app/common/test_helpers/composable/gen.cljc index 7365d06f29..8594460b9f 100644 --- a/common/src/app/common/test_helpers/composable/gen.cljc +++ b/common/src/app/common/test_helpers/composable/gen.cljc @@ -149,6 +149,12 @@ [situation opts] (let [library (-> (tm/make-situation (thf/sample-file :random-library :name "random-library" :is-shared true)) (as-> s (tm/apply-to (n/create-component "library-random" setup/labeled-fill :size 100) s)) + (as-> s (if (:library-grid opts) + (-> s + (with-layout "library-random" :grid) + (with-layout-children "library-random") + (with-square-grid "library-random")) + s)) (as-> s (tm/apply-to (n/make-nested-component "library-random" (or (:library-depth opts) 1)) s)) (as-> s (if (:library-variants opts) (tm/apply-to (n/make-variant-container "library-variants" @@ -696,6 +702,8 @@ (defn settle-state [{:keys [situation model checkpoint] :as state}] (let [settled (r/settle situation) + _ (when-let [{:keys [before model root-id]} (:update-main-intent state)] + (oracle/check-requested-update-main before settled model root-id)) model (-> model (shadow/parent-orientation (all-objects situation) (all-objects settled)) (shadow/settle (all-objects settled))) @@ -717,7 +725,7 @@ (when-not (oracle/equivalent? settled-design full-design) (oracle/fail :I5 {:diff (thn/diff settled-design full-design)})) (when checkpoint (assert-round-trip checkpoint settled journal)) - (cond-> (assoc state :situation settled :model model :checkpoint nil) + (cond-> (dissoc (assoc state :situation settled :model model :checkpoint nil) :update-main-intent) journal (assoc-in [:undo (dec (count (:undo state)))] (dissoc journal :reference-start))))) (defn- source-context @@ -833,6 +841,11 @@ :undo (restore-references situation (:reference-before (peek (:undo state)))) :redo (restore-references situation (:reference-after (peek (:redo state)))) situation) + ;; Retain file inputs, without runner history, through deferred sync. + intent (when (= kind :update-main) + {:before (-> (tm/make-situation (tm/file situation)) + (tm/with-aux-files (tm/aux-files situation))) + :model model :root-id (get-in resolved [:shape :id])}) after (cond library-id (apply-source situation library-id op kind) (= kind :sync) @@ -849,6 +862,8 @@ (get (oracle/snapshot after) owner)) (assoc-in [:library-histories owner :foreign-write] true))) after (keys (:library-histories situation)))) + _ (when (= kind :update-main) + (oracle/check-requested-update-main (:before intent) after model (:root-id intent))) changed (not= (r/undo-depth situation) (r/undo-depth after)) history (:undo state) redo (:redo state) @@ -864,6 +879,7 @@ (oracle/design-snapshot after {:free-head-placement false}))) state (-> state (assoc :situation after :model next-model) + (cond-> intent (assoc :update-main-intent intent)) (update-in (conj coverage-path (if meaningful :changed :no-op)) (fnil inc 0)) (cond-> (and (not meaningful) (> (r/undo-depth after) (r/undo-depth situation))) diff --git a/common/src/app/common/test_helpers/composable/oracle.cljc b/common/src/app/common/test_helpers/composable/oracle.cljc index 0fbae2938d..8a421d1d68 100644 --- a/common/src/app/common/test_helpers/composable/oracle.cljc +++ b/common/src/app/common/test_helpers/composable/oracle.cljc @@ -278,25 +278,26 @@ [id (gpt/point (:x expected) (:y expected))]))) (defn- geometry-differences - [objects shape expected] - (let [layout-child (and (ctl/any-layout-immediate-child? objects shape) - (not (ctl/position-absolute? shape))) - auto-width (and (= :text (:type shape)) (= :auto-width (:grow-type shape))) - auto-height (and (= :text (:type shape)) (#{:auto-width :auto-height} (:grow-type shape))) - derived (derived-attributes objects shape) - width-owned (contains? derived :width) - height-owned (contains? derived :height)] - (cond-> #{} - (not (mth/close? (or (:rotation shape) 0) (or (:rotation expected) 0) 0.01)) (conj :rotation) - (not= (boolean (:flip-x shape)) (boolean (:flip-x expected))) (conj :flip-x) - (not= (boolean (:flip-y shape)) (boolean (:flip-y expected))) (conj :flip-y) - (and (not width-owned) (not (mth/close? (:width shape) (:width expected) 0.01))) (conj :width) - (and (not height-owned) (not (mth/close? (:height shape) (:height expected) 0.01))) (conj :height) - (and (not layout-child) auto-height - (not (gsh/close-attrs? :points [(first (:points shape))] - [(first (:points expected))] 0.01))) (conj :position) - (and (not layout-child) (not auto-width) (not auto-height) - (not (gsh/close-attrs? :points (:points shape) (:points expected) 0.01))) (conj :points)))) + ([objects shape expected] (geometry-differences objects shape expected shape)) + ([objects shape expected ownership] + (let [layout-child (and (ctl/any-layout-immediate-child? objects ownership) + (not (ctl/position-absolute? ownership))) + auto-width (and (= :text (:type ownership)) (= :auto-width (:grow-type ownership))) + auto-height (and (= :text (:type ownership)) (#{:auto-width :auto-height} (:grow-type ownership))) + derived (derived-attributes objects ownership) + width-owned (contains? derived :width) + height-owned (contains? derived :height)] + (cond-> #{} + (not (mth/close? (or (:rotation shape) 0) (or (:rotation expected) 0) 0.01)) (conj :rotation) + (not= (boolean (:flip-x shape)) (boolean (:flip-x expected))) (conj :flip-x) + (not= (boolean (:flip-y shape)) (boolean (:flip-y expected))) (conj :flip-y) + (and (not width-owned) (not (mth/close? (:width shape) (:width expected) 0.01))) (conj :width) + (and (not height-owned) (not (mth/close? (:height shape) (:height expected) 0.01))) (conj :height) + (and (not layout-child) auto-height + (not (gsh/close-attrs? :points [(first (:points shape))] + [(first (:points expected))] 0.01))) (conj :position) + (and (not layout-child) (not auto-width) (not auto-height) + (not (gsh/close-attrs? :points (:points shape) (:points expected) 0.01))) (conj :points))))) (defn check-requested-geometry [objects actual expected] @@ -313,6 +314,65 @@ shape)] (shadow/values shape group))) +(defn- get-world-objects + [situation] + (into {} (mapcat cf/object-trees) (vals (cf/all-files situation)))) + +(defn check-requested-update-main + "Keep authored intent after the shadow clears the source copy's groups. + Only identities come from the result; expected values come from before." + [before after model root-id] + (let [source-objects (get-world-objects before) + objects (get-world-objects after) + root (get source-objects root-id) + main-id (:shape-ref root) + subtree (fn subtree [objects id] + (cons id (mapcat #(subtree objects %) (:shapes (get objects id))))) + destination (set (subtree objects main-id)) + mismatch (fn [id group expected actual] + (fail :I9 {:phase :requested-update-main :shape-id id :group group + :expected expected :actual actual}))] + (doseq [id (subtree source-objects root-id) + :let [source (get source-objects id) + kept (get objects id) + target (get objects (if (= id root-id) main-id (:shape-ref kept)))] + group (keys (get model id))] + (when-not (and kept target (contains? destination (:id target))) + (mismatch id group :destination-main (:id target))) + (cond + (= group :geometry-group) + ;; The source copy stays in its own frame. Existing geometry ownership + ;; and tolerance apply; I4 then checks its placement against the main. + (let [attrs (geometry-differences source-objects kept source source)] + (when (or (seq attrs) + (not= (or (:content-scale source) 1) (or (:content-scale kept) 1))) + (mismatch id group (shadow/values source group) (shadow/values kept group)))) + + (= group :swap-group) + (when-not (= (select-keys source [:component-id :component-file]) + (select-keys target [:component-id :component-file])) + (mismatch id group (select-keys source [:component-id :component-file]) + (select-keys target [:component-id :component-file]))) + + :else + (let [source-parent (get source-objects (:parent-id source)) + item-group (.startsWith (name group) "layout-item-") + intrinsic (and (:layout source) + (#{:layout-item-h-sizing :layout-item-v-sizing} group) + (#{:fix :auto} (get source group))) + push-item (or intrinsic + (and (not= id root-id) (:layout source-parent))) + target (if (and item-group (not push-item)) kept target) + expected (if (= group :layout-grid-cells) + (get (grid/remap-groups {group (shadow/values source group)} + (grid/get-child-map objects source target)) group) + (comparable-values source target group)) + actual (comparable-values target target group)] + (when-not (if (contains? shadow/text-groups group) + (shadow/same-value? target group expected) + (= expected actual)) + (mismatch id group expected actual))))))) + (defn- grid-cells [shape] (let [indices (zipmap (:shapes shape) (range))] diff --git a/common/test/common_tests/logic/composable_gen_test.cljc b/common/test/common_tests/logic/composable_gen_test.cljc index ae1185c16e..1c662e95a4 100644 --- a/common/test/common_tests/logic/composable_gen_test.cljc +++ b/common/test/common_tests/logic/composable_gen_test.cljc @@ -29,6 +29,71 @@ (t/use-fixtures :each thi/test-fixture) +(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]]} + {:world [1 0 {:library true :library-depth 0 :library-grid true}] + :ops [[:grid-cell 0 0 0 2] [:update-main 0]]} + {:world [1 0 {:layout :grid :layout-children true :grid-square true}] + :ops [[:grid-cell 0 0 0 1] [:update-main 0]]}]] + (t/is (map? (cg/run program)) "Real update-main preserves the authored value") + (let [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)) (pr-str failure)) + (t/is (= :requested-update-main (:phase failure)) (pr-str failure))))) + +(t/deftest update-main-checks-scalar-text-and-geometry-intent + (let [styles (for [property (range (count cg/style-edits))] + {:world [1 0 {:layout (if (= property 26) :grid :flex) + :layout-children true :layout-item-margins true}] + :ops [[:style 0 property (if (= property 27) 0 1) 1] [:update-main 0]]}) + texts (for [unit (range (count cg/text-style-edits))] + {:world [1 0 {:text true :text-styles true}] + :ops [[:text-style 1 unit 1] [:update-main 0]]}) + geometry (for [action (range 1 6)] + {:world [1 0] :ops [[:transform 0 action 2 4] [:update-main 0]]}) + programs (concat styles texts geometry + [{:world [1 0 {:text true :text-styles true}] + :ops [[:text 1 0 1] [:update-main 0]]} + {:world [1 0] :ops [[:transform 0 0 1 2] [:update-main 0]]}])] + (doseq [program programs] + (let [result (cg/run program) + 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 (= 1 (get-in result [:coverage :random :update-main :changed])) (pr-str program)) + (t/is (= :I9 (:invariant failure)) (pr-str [program failure])) + (t/is (= :requested-update-main (:phase failure)) (pr-str [program failure])))))) + +(t/deftest update-main-intent-survives-until-deferred-sync-finishes + (let [edited (-> (cg/initial-state [1 0]) (cg/step [:edit 0 0 1 1]) cg/settle-state) + id (get-in (cg/resolve-op (:situation edited) (:model edited) [:update-main 0]) [:shape :id]) + source (tm/shape-by-id (:situation edited) id) + main (tm/shape-by-id (:situation edited) (:shape-ref source)) + ids (mapv (comp :id :shape) (filter #(= (:component-id source) (get-in % [:shape :component-id])) + (cg/tree (:situation edited)))) + updated (cg/step edited [:update-main 0]) + settle r/settle + corrupt (fn [situation] + (let [file (tm/file situation) + page (thf/current-page file) + changes (cls/generate-update-shapes (pcb/empty-changes nil (:id page)) ids + #(assoc % :fills (:fills main)) (:objects page) + {:ignore-touched true})] + (tm/with-file situation (thf/apply-changes file changes)))) + check (fn [synchronize] + (with-redefs [r/settle (fn + ([situation] (corrupt (settle situation (r/pending-components situation)))) + ([situation components] (corrupt (settle situation components))))] + (try (cg/settle-state (cond-> updated synchronize (cg/step [:sync]))) nil + (catch #?(:clj Exception :cljs js/Error) error (ex-data error)))))] + (t/is (= (:fills source) (:fills (tm/shape-by-id (:situation updated) (:id main))))) + (doseq [synchronize [false true]] + (let [failure (check synchronize)] + (t/is (= :I9 (:invariant failure)) (pr-str failure)) + (t/is (= :requested-update-main (:phase failure)) (pr-str failure)))))) + (t/deftest authored-grid-cell-values-are-checked-against-intent-instead-of-the-main (let [situation (cg/world [1 0 {:layout :grid :layout-children true}]) id ((n/nth-copy-head-of "random-0" 0) situation) diff --git a/frontend/test/frontend_tests/composable_tests/generated_test.cljs b/frontend/test/frontend_tests/composable_tests/generated_test.cljs index 33b43f0a3c..89de0b9606 100644 --- a/frontend/test/frontend_tests/composable_tests/generated_test.cljs +++ b/frontend/test/frontend_tests/composable_tests/generated_test.cljs @@ -13,6 +13,7 @@ [app.common.test-helpers.composable.oracle :as oracle] [app.common.test-helpers.files :as cthf] [app.common.test-helpers.normalize :as thn] + [app.main.data.workspace.libraries :as dwl] [app.main.repo :as rp] [beicon.v2.core :as rx] [cljs.test :as t :include-macros true] @@ -60,6 +61,9 @@ next-state (-> state (cg/step tuple) (cg/settle-state))] (when-not next-live (throw (ex-info "Frontend step failed" {:program program :tuple tuple}))) + (when (and (:op actual) (= :update-main (first tuple))) + (oracle/check-requested-update-main live next-live (live-model state live) + (get-in actual [:shape :id]))) (when (and (:op actual) (#{:resize :rotate :transform} (first tuple))) (oracle/check-requested-geometry (:objects (cthf/current-page (tm/file next-live))) @@ -87,14 +91,60 @@ (ftm/uninstall!))))) (catch :default error (ftm/uninstall!) - (t/is false (str (ex-message error) "\nReplay: " (pr-str program) - "\nDetails: " (pr-str (ex-data error))))))) + (throw error)))) (defn ^:async replay [program] (await (mock/with-mocks* {rp/cmd! mock/rpc-cmd-mock rx/timer mock/timer-mock} - (await (replay-program program))))) + (try (await (replay-program program)) + (catch :default error + (t/is false (str (ex-message error) "\nReplay: " (pr-str program) + "\nDetails: " (pr-str (ex-data error))))))))) + +(def update-main-intent-programs + [{:world [1 0] :ops [[:edit 0 0 1 1] [:update-main 0] [:undo] [:redo]]} + {:world [1 0 {:library true}] :ops [[:edit 0 0 1 2] [:update-main 0] [:undo] [:redo]]} + {:world [1 0 {:layout :grid :layout-children true :grid-square true}] + :ops [[:grid-cell 0 0 0 1] [:update-main 0] [:undo] [:redo]]} + {:world [1 0 {:library true :library-depth 0 :library-grid true}] + :ops [[:grid-cell 0 0 0 2] [:update-main 0] [:undo] [:redo]]} + {:world [1 0 {:text true :text-styles true}] + :ops [[:text-style 1 2 1] [:update-main 0] [:undo] [:redo]]} + {:world [1 0] :ops [[:transform 0 3 2 4] [:update-main 0] [:undo] [:redo]]}]) + +(t/deftest ^:async update-main-preserves-authored-intent-in-the-destination + (doseq [program update-main-intent-programs] + (await (replay program)))) + +(t/deftest ^:async update-main-intent-rejects-a-reset-dispatched-by-the-editor + (await + (mock/with-mocks* {rp/cmd! mock/rpc-cmd-mock rx/timer mock/timer-mock} + (doseq [{:keys [world ops]} update-main-intent-programs] + (let [state (cg/initial-state world) + live (ftm/start-generated (:situation state)) + edit (first ops) + edited (await (ftm/run-generated-step live (:op (cg/resolve-op live {} edit)))) + state (-> state (cg/step edit) cg/settle-state) + model (live-model state edited) + request (cg/resolve-op edited model [:update-main 0]) + result (await (mock/with-mocks* {dwl/update-component-sync (fn [id _] (dwl/reset-component id))} + (await (ftm/run-generated-step edited (:op request))))) + settled (try (oracle/check result {}) nil + (catch :default error (ex-data error))) + failure (try (oracle/check-requested-update-main edited result model (get-in request [:shape :id])) nil + (catch :default error (ex-data error)))] + (t/is (nil? settled) "The wrong main and every copy agree") + (t/is (= :I9 (:invariant failure)) (pr-str failure)) + (t/is (= :requested-update-main (:phase failure)) (pr-str failure)) + (let [checked (await (ftm/finish-generated result))] + (t/is (empty? (uc/failures checked)) (pr-str (uc/failures checked)))) + (ftm/uninstall!) + (let [failure (await (mock/with-mocks* {dwl/update-component-sync (fn [id _] (dwl/reset-component id))} + (try (await (replay-program {:world world :ops ops})) nil + (catch :default error (ex-data error)))))] + (t/is (= :I9 (:invariant failure)) (pr-str failure)) + (t/is (= :requested-update-main (:phase failure)) (pr-str failure)))))))) (t/deftest ^:async authored-grid-histories-use-independent-cell-expectations (doseq [ops [[[:grid-direction 0 0 1 1] [:grid-direction 0 0 1 0]