🐛 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/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)))

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))]

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)

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]