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]