diff --git a/.serena/memories/frontend/composable-component-tests.md b/.serena/memories/frontend/composable-component-tests.md index 0185e2fc33..839eecc4da 100644 --- a/.serena/memories/frontend/composable-component-tests.md +++ b/.serena/memories/frontend/composable-component-tests.md @@ -99,8 +99,8 @@ Two pure runners (no store, JVM + CLJS): situation's files) once settled: after the sync fixpoint and after an undo group; never between cascade passes, where an outer copy still points at the component its main dropped (`:component-id-mismatch`), nor with `{:sync? false}`. Assembly ops (create/instantiate/nest/variant - container): no sync, no undo group. `ResetCopyInstance` is a user op here (sync + undo), - unlike the interpreter (file install). `{:sync? false}` disables sync. `Rotate`/`ChangeHeight`/`MoveShape` + container): no sync, no undo group. `n/reset` (`reset-copy-instance` resets a lineage's latest copy) is a user op here (sync + + undo), unlike the interpreter (file install). `{:sync? false}` disables sync. `Rotate`/`ChangeHeight`/`MoveShape` are `:frontend-only` and throw `::runner/frontend-only` (the placement step is frontend code). Swap and switch nodes use the production `clv/generate-component-swap-in-place` (+ `clv/find-switch-target` for switch), the same code the frontend events call. Not modelled: the `:modified-at` bump, and the swap/switch event follow-ups @@ -143,8 +143,10 @@ Two pure runners (no store, JVM + CLJS): - `n/create-component` builds 0.01-sized frames unless given `:size`. The transform math writes float noise into those sizes, so frontend syncs emit reflows whose commits lose their undo group (F43) at timing-dependent points (`initialize-shape-layout` buffers - `:layout/update` in 100 ms windows): undo pins over such reflows can be nondeterministic. + `:layout/update` in 100 ms windows): undo pins over such reflows are nondeterministic. New cases that are not about geometry pass `:size` (nesting sizes the outer frames too). + F43 lives in case AJ only (frontend only, round trip off): it pins the value one undo + leaves, which does not depend on how many entries the reflow makes. - Case assertions a known bug breaks use `tm/known-failure bug expected pinned actual`: a strict expected failure at assertion level (passes only while `actual` is the pinned wrong value). The undo-check marks cover only round-trip failures. @@ -153,8 +155,11 @@ Two pure runners (no store, JVM + CLJS): setup `simple-text-component-with-copy` (text named after its content). - The interpreter unwraps nested choices (`(tm/optional (tm/one-of …))`); `(optional (in-sequence …))` is still not flattened. +- Depth sweeps: `depth-sweep` in `cases.cljc`, a one-of over skip, + `(n/make-nested-component name)` and `(n/make-nested-component name 2)`; asserters read + `n/nesting-depth`. Two independent nesting optionals run depth 1 twice. - General target-based nodes: `n/swap-shape target to` (`to` a lineage name or a component label), `n/move-to-cell board child row column`, `n/reset target` (a file install - in the interpreter, like `reset-copy-instance`). `n/nested-head-in name` finds a copy's nested + in the interpreter). `n/swap-component name level to` is `swap-shape` on `n/nested-head-of`. `n/nested-head-in name` (and the general `n/nested-head-under parent-target`) finds a copy's nested head through its parent, so it survives swaps and switches (they keep the head id anyway). Careful: `n/lineage-component-id` is the OUTER component after nesting. - `n/undo-before-sync` (frontend-only) emits an edit and `dwu/undo` in one step, so the undo @@ -163,7 +168,7 @@ Two pure runners (no store, JVM + CLJS): before running the next one (`thi/id` then points at the new run's shapes). Case letters B..Z, then AA..; the sweeps (K: depth × edit-precedence; L: swaps; M: variant switches; N: rotated-instance geometry, on the #10109 fix branch until merged; O: switch of an overridden copy, mains -agreeing or not; Q: detach at depth 0..2, nested copies stay linked; R: update-main at depth 0..2 with two copies; S: delete/restore with a copy on another page; T: duplicate a copy at depth 0..2; U: move a copy into a main with a copy; V: new edit after undo empties redo; W: `(n/undo 3)` over nested cascades; X: undo before the edit's sync, frontend only; Y: text override × main text change, per subgroup; Z: main child move, frontend only; AA..AE: swap outcomes asserted on values, not slot storage, so they survive the Phase 2b swap model; AF: grid cell move vs a swapped copy child, setup `grid-component-with-copy`; AG/AH/AI: ports of the plugin's slot-alignment cases, setup `component-with-sibling-instances`, check `setup/misaligned-sub-heads`) are the flagship pattern — read them before +agreeing or not; Q: detach at depth 0..2, nested copies stay linked; R: update-main at depth 0..2 with two copies; S: delete/restore with a copy on another page; T: duplicate a copy at depth 0..2; U: move a copy into a main with a copy; V: new edit after undo empties redo; W: `(n/undo 3)` over nested cascades; X: undo before the edit's sync, frontend only; AJ: F43, one undo after a nested sync reverts only the reflow, frontend only; Y: text override × main text change, per subgroup; Z: main child move, frontend only; AA..AE: swap outcomes asserted on values, not slot storage, so they survive the Phase 2b swap model; AF: grid cell move vs a swapped copy child, setup `grid-component-with-copy`; AG/AH/AI: ports of the plugin's slot-alignment cases, setup `component-with-sibling-instances`, check `setup/misaligned-sub-heads`) are the flagship pattern — read them before writing a new sweep. **Scenario lineage model** (behind the sweeps): scenario ops track named component lineages as @@ -250,7 +255,7 @@ Distinguishing abstractions (the OOP articulation of the shared principles): - `OpDetach`/`OpSwap`/`OpReset` wait for pending propagation before acting (a script could otherwise act inside the sync window, which no user can). `swapComponent` keeps touched (F33). The suite pins published `@penpot/plugin-types` 1.4.2, which lacks `resetOverrides` (typed cast). -- Known bugs: `Assert.knownFailure(bug, actual, expected, pinned, equals)`, the counterpart of +- Known bugs: `Assert.knownFailure(bug, expected, pinned, actual, equals)` (same order as `tm/known-failure`), the counterpart of `tm/known-failure`. - Panel checkboxes carry stable DOM ids (case identifier / `Identifier-N` composites) for remote control via Playwright; recipe in the README. diff --git a/common/dev/bench/component_sync.clj b/common/dev/bench/component_sync.clj index 28a36e255d..29c46479b1 100644 --- a/common/dev/bench/component_sync.clj +++ b/common/dev/bench/component_sync.clj @@ -16,12 +16,12 @@ Run from `common/` with `scripts/bench-components` (`record` writes the baseline, `compare`, the default, checks against it)." (:require - [app.common.files.changes :as ch] [app.common.files.changes-builder :as pcb] [app.common.logic.libraries :as cll] [app.common.logic.shapes :as cls] [app.common.logic.variants :as clv] [app.common.test-helpers.components :as thc] + [app.common.test-helpers.composable.comp.runner :as r] [app.common.test-helpers.compositions :as tho] [app.common.test-helpers.files :as thf] [app.common.test-helpers.ids-map :as thi] @@ -54,35 +54,6 @@ [file changes] (thf/apply-changes file changes :validate? false)) -(defn- changed-components - "Ids of the components whose main `changes` modified, judged against - `old-data`, the file data before them." - [old-data changes] - (into #{} (mapcat (partial ch/components-changed old-data)) (:redo-changes changes))) - -(defn- sync-cascade - "Sync the copies of `component-ids` in `file`, then those of the components - each sync changed, until none is left. `libraries` are the other files. - Returns `[file passes]`." - [file libraries component-ids] - (loop [file file - pending (vec component-ids) - passes 0] - (if (empty? pending) - [file passes] - (let [file-id (:id file) - changes (cll/generate-sync-file-changes (pcb/empty-changes) - nil - :components - file-id - (first pending) - file-id - (assoc libraries file-id file) - file-id) - file' (apply-changes file changes) - more (remove (set pending) (changed-components (:data file) changes))] - (recur file' (into (subvec pending 1) more) (inc passes)))))) - (defn- edit "`file` after `f` changed the shape `label` through the production path, and the ids of the components that changed." @@ -93,7 +64,14 @@ f (:objects page) {})] - [(apply-changes file changes) (changed-components (:data file) changes)])) + [(apply-changes file changes) (r/changed-components (:data file) changes)])) + +(defn- sync-cascade + "`[file passes]` after syncing the copies of `component-ids` in `file` to + a fixpoint (see `r/sync-cascade`)." + [file libraries component-ids] + (let [{:keys [file passes]} (r/sync-cascade file libraries component-ids)] + [file passes])) (defn- red [shape] @@ -196,7 +174,7 @@ page libs (:data file) shape (:id target) true)] (sync-cascade (apply-changes file changes) {} - (changed-components (:data file) changes))))] + (r/changed-components (:data file) changes))))] {:key :variant-switch-into-copies :describe "a variant copy in a main switches; 100 copies of the main sync" :run switch diff --git a/common/src/app/common/test_helpers/composable/comp/cases.cljc b/common/src/app/common/test_helpers/composable/comp/cases.cljc index 29f0b1c308..a028ee5fc2 100644 --- a/common/src/app/common/test_helpers/composable/comp/cases.cljc +++ b/common/src/app/common/test_helpers/composable/comp/cases.cljc @@ -5,20 +5,15 @@ ;; Copyright (c) KALEIDOS SUBSIDIARY SL (ns app.common.test-helpers.composable.comp.cases - "Component-behaviour cases authored on the composable test model, shared by - both runners: the frontend interpreter (the real app, in - `frontend-tests.composable-tests.comp.sync-test`) and the pure runner - (`app.common.test-helpers.composable.comp.runner`, in - `common-tests.logic.composable-sync-test`). + "Component cases of the composable test model, run by the frontend + interpreter (`frontend-tests.composable-tests.comp.sync-test`) and by the + pure runner (`common-tests.logic.composable-sync-test`). - Each case is a zero-arg function returning `{:setup :operation :asserter}`. - Assertions use `clojure.test` (`cljs.test` in CLJS), inline through `Test` - operations and/or in the optional trailing `:asserter`, which receives the - resulting situation of each enumerated variant. A case contains only the user - edits: the runner syncs copies on its own, and that is what the cases - assert. + A case is a zero-arg fn returning `{:setup :operation :asserter}`; the + asserter gets the resulting situation of each variant. A case holds only + user actions: the runners sync the copies, and the cases assert on that. - The cases (see `mem:frontend/composable-component-tests` for details): + The cases (`mem:frontend/composable-component-tests`): B — an override on a copy child survives a later main change (touched gate). C — a sweep (one-of) over several attribute changes, each propagating. D — a shape added to the main is structurally propagated (ref-integrity). @@ -28,8 +23,8 @@ the explicit library sync (cross-file propagation). I — undo reverses an edit AND its propagation. P — redo applies an undone edit and its propagation again. - K — the synchronisation sweep: depth x edit-targets, with override-precedence - and reset checkpoints. + K — edits at depth 0..2: the copy's own, else its main's, else the + remote's; a reset keeps the main's. L — the swap sweep: swaps at any subset of nesting levels. M — the variant-switch sweep: case L with variant switches. O — a variant switch keeps a copy override only where the mains agree. @@ -42,6 +37,8 @@ W — one undo node undoes several steps over nested cascades. X — an undo committed before the edit's sync leaves copies unchanged (frontend only). + AJ — one undo after a nested sync reverts only the reflow (F43, frontend + only). Y — a text override merges with a main text change per subgroup. Z — a move of a main child reaches the copies (frontend only). AA..AE — swap outcomes: a copy's swap survives main changes; reset of a @@ -51,7 +48,7 @@ AG — a main reorder keeps the copy's nested copies aligned. AH, AI — a copy deleting a nested copy keeps the others aligned (AI also reflows, frontend only). - N — geometry sync with rotated instances (needs the frontend placement step). + N — main edits reach rotated copies (frontend only). Rotation — a touched copy child survives a main rotation (frontend only too)." (:require [app.common.data :as d] @@ -72,40 +69,50 @@ (def ^:private red "#ff0000") (def ^:private green "#00ff00") (def ^:private blue "#0000ff") +(def ^:private base-color "#aaaaaa") -;; (Cases A, G, J retired — subsumed by case K's depth-swept propagation scenario.) +(defn- fill-color + [shape] + (-> shape :fills first :fill-color)) + +(defn- depth-sweep + "One variant per nesting depth 0, 1 and 2 of lineage `name`." + [name] + (tm/one-of [(tm/skip) + (n/make-nested-component name) + (n/make-nested-component name 2)])) (defn copy-override-survives-later-main-change - "Case B." + "Case B. A copy overrides its child's fill, then the main changes it. The + override survives, touched." [] - (let [override (n/change-attr :copy-child :fills green)] ; touch the copy first + (let [override (n/change-property :copy-child :fills green)] {:setup setup/simple-component-with-labeled-copy - ;; override the copy, then change the main; sync runs after each edit. The - ;; override must survive (touched-flag gate). :operation (tm/in-sequence [override - (n/change-attr :main-child :fills red)]) + (n/change-property :main-child :fills red)]) :asserter (fn [situation] (let [copy-child (setup/copy-instance situation)] - (t/is (n/has-attr? override copy-child)) + (t/is (n/has-property-of override copy-child)) (t/is (contains? (:touched copy-child) :fill-group)) (t/is (some? (:shape-ref copy-child)))))})) (defn attribute-sweep-propagates-to-clean-copy - "Case C." + "Case C. A main change of fill or opacity reaches a clean copy." [] (let [sweep (tm/one-of - [(n/change-attr :main-child :fills red) - (n/change-attr :main-child :opacity 0.5)])] + [(n/change-property :main-child :fills red) + (n/change-property :main-child :opacity 0.5)])] {:setup setup/simple-component-with-copy :operation (tm/in-sequence [sweep]) :asserter (fn [situation] (let [chosen (tm/get-choice situation sweep)] (t/is (some? chosen)) - (t/is (n/has-attr? chosen (setup/copy-instance situation)))))})) + (t/is (n/has-property-of chosen (setup/copy-instance situation)))))})) (defn add-shape-to-main-propagates-to-clean-copy - "Case D." + "Case D. A shape added to the main appears in the copy, linked to it and + untouched." [] (let [add (n/add-child :main-root :main-child-2)] {:setup setup/simple-component-with-labeled-copy @@ -120,7 +127,8 @@ (t/is (nil? (:touched copy-new)))))})) (defn remove-shape-from-main-propagates-to-clean-copy - "Case E." + "Case E. The middle of three main children is deleted; the copy loses it + and keeps the others in order, linked and untouched." [] (let [removal (n/remove-child :main-child2)] {:setup setup/component-with-many-children @@ -140,7 +148,8 @@ (t/is (nil? (:touched copy-root)))))})) (defn move-shape-in-main-propagates-order-to-clean-copy - "Case F." + "Case F. The main moves its first child to the end; the copy follows, its + children linked and untouched." [] (let [move (n/move-child :main-child1 :main-root 2)] {:setup setup/component-with-many-children @@ -168,245 +177,147 @@ (defn undo-reverts-edit-and-its-propagation "Case I. Change the main (which propagates to the clean copy), then undo. A - single undo reverses the whole logical action — the edit AND its - propagation — so the copy returns to baseline and is left untouched." + single undo reverses the edit and its propagation, so main and copy are + back to the first fill and the copy is untouched." [] - (let [original "#abcdef" ; the labeled setup's starting fill - baseline (n/change-attr :main-child :fills original) ; expected-VALUE descriptor - change (n/change-attr :main-child :fills red)] - {:setup setup/simple-component-with-labeled-copy - :operation (tm/in-sequence [change (n/undo)]) - :asserter (fn [situation] - (let [copy (setup/copy-instance situation) - main (setup/main-instance situation)] - ;; the edit was reversed on the main … - (t/is (n/has-attr? baseline main)) - ;; … and on the copy (the propagation was reversed too) … - (t/is (n/has-attr? baseline copy)) - ;; … leaving the copy clean. - (t/is (nil? (:touched copy)))))})) + {:setup setup/simple-component-with-labeled-copy + :operation (tm/in-sequence [(n/change-property :main-child :fills red) (n/undo)]) + :asserter (fn [situation] + (let [copy (setup/copy-instance situation)] + (t/is (= setup/labeled-fill (fill-color (setup/main-instance situation)))) + (t/is (= setup/labeled-fill (fill-color copy))) + (t/is (nil? (:touched copy)))))}) (defn redo-reapplies-edit-and-its-propagation "Case P. Change the main (which propagates to the clean copy), undo, then redo. The redo applies the edit and its propagation again, so the copy shows the main's new value and is left untouched." [] - (let [change (n/change-attr :main-child :fills red)] + (let [change (n/change-property :main-child :fills red)] {:setup setup/simple-component-with-labeled-copy :operation (tm/in-sequence [change (n/undo) (n/redo)]) :asserter (fn [situation] (let [copy (setup/copy-instance situation) main (setup/main-instance situation)] - (t/is (n/has-attr? change main)) - (t/is (n/has-attr? change copy)) + (t/is (n/has-property-of change main)) + (t/is (n/has-property-of change copy)) (t/is (nil? (:touched copy)))))})) (defn library-change-propagates-across-file-boundary-on-sync - "Case H. The main lives in a linked LIBRARY, the copy in the consuming - (current) file. The library main has diverged (setup applied `red` to it, - leaving the copy stale). In-file sync does NOT cross the file boundary; the - app propagates via the library-UPDATE action, so the operation is - `sync-from-library`. `expected` is only an expected-VALUE descriptor (its - target is irrelevant; `has-attr?` uses just attr+value)." + "Case H. The main lives in a linked library, the copy in the consuming + (current) file. The library main has diverged (the setup filled it `red`, + leaving the copy stale). In-file sync does not cross the file boundary; + the app propagates through the library update action, so the operation is + `sync-from-library`." [] - (let [expected (n/change-attr :main-child :fills red)] - {:setup #(setup/cross-file-component-with-copy red) - :operation (tm/in-sequence [(n/sync-from-library)]) - :asserter (fn [situation] - (t/is (n/has-attr? expected (setup/copy-instance situation))))})) + {:setup #(setup/cross-file-component-with-copy red) + :operation (tm/in-sequence [(n/sync-from-library)]) + :asserter (fn [situation] + (t/is (= red (fill-color (setup/copy-instance situation)))))}) (defn synchronisation-scenarios - "Case K. CONSOLIDATED SCENARIO SWEEP — one composition standing in for many - cases. Built from the sync-scenario operations on an empty situation. It - sweeps: - - DEPTH 0/1/2 via two independent `(optional (make-nested-component ...))` - - which EDITS were made via three independent `(optional change-*)` - and asserts, at INLINE checkpoints, the override-precedence and reset rules. - The change targets are the tracked lineage rects, so the same composition - holds at any depth. Subsumes the flat/nested propagation cases (A/G/J)." + "Case K. At nesting depth 0, 1 or 2, optionally the remote main, the main + and the copy change their rect. The copy shows its own change, else the + main's, else the remote's, else the first fill. Then the copy overrides + its rect and resets: it shows the main's change, else the remote's, else + the first fill." [] - (let [m "main" + (let [m "main" change-remote (n/change-property (n/remote-rect-of m) :fills red) change-main (n/change-property (n/main-rect-of m) :fills green) change-copy (n/change-property (n/copy-rect-of m) :fills blue) - copy-rect (fn [s] (n/lineage-copy-rect s m)) - ;; precedence at the copy: copy override wins; else main; else remote. - expected-after-edits - (fn [s] - (cond - (tm/applied? s change-copy) (n/has-property-of change-copy (tm/shape-by-id s (copy-rect s))) - (tm/applied? s change-main) (n/has-property-of change-main (tm/shape-by-id s (copy-rect s))) - (tm/applied? s change-remote) (n/has-property-of change-remote (tm/shape-by-id s (copy-rect s))) - :else true))] + force-copy (n/change-property (n/copy-rect-of m) :fills blue) + copy-color (fn [s] (fill-color (tm/shape-by-id s (n/lineage-copy-rect s m)))) + main-color (fn [s] + (cond + (tm/applied? s change-main) green + (tm/applied? s change-remote) red + :else base-color))] {:setup setup/empty-situation :operation (tm/in-sequence - [(n/create-component m red) - ;; depth sweep: two independent optionals give depths 0/1/2 - ;; (depth 1 appears twice — harmless) without nesting a - ;; Sequence inside an optional. - (tm/optional (n/make-nested-component m)) - (tm/optional (n/make-nested-component m)) + [(n/create-component m base-color :size 100) + (depth-sweep m) (n/instantiate-copy m) (tm/optional change-remote) (tm/optional change-main) (tm/optional change-copy) - (tm/test-that (fn [s] (t/is (expected-after-edits s)))) - ;; force a copy override, observe it wins, then reset it away - change-copy - (tm/test-that - (fn [s] (t/is (n/has-property-of change-copy (tm/shape-by-id s (copy-rect s)))))) - (n/reset-copy-instance m) (tm/test-that (fn [s] - ;; after reset: main's value if main changed, else remote's - ;; if remote changed (else the original — not asserted). - (cond - (tm/applied? s change-main) (t/is (n/has-property-of change-main (tm/shape-by-id s (copy-rect s)))) - (tm/applied? s change-remote) (t/is (n/has-property-of change-remote (tm/shape-by-id s (copy-rect s)))) - :else true)))])})) + (t/is (= (if (tm/applied? s change-copy) blue (main-color s)) + (copy-color s))))) + force-copy + (tm/test-that (fn [s] (t/is (= blue (copy-color s))))) + (n/reset-copy-instance m) + (tm/test-that (fn [s] (t/is (= (main-color s) (copy-color s)))))])})) (defn- level-color - "The fill colour of the rect currently at lineage `name`'s nesting level `i`." + "The fill of the rect at lineage `name`'s nesting level `i`." [s name i] - (-> (tm/shape-by-id s (n/level-rect s name i)) :fills first :fill-color)) + (fill-color (tm/shape-by-id s (n/level-rect s name i)))) -(def ^:private base-color "#aaaaaa") (def ^:private swap-colors ["#ff0000" "#00ff00" "#0000ff"]) ; level 0/1/2 targets -(def ^:private level-0-reflow-left - ;; what one undo of a first step at level 0 leaves in place - #{[:object :sync-main-innercopy-0 :component-id] - [:object :sync-main-innercopy-0 :shape-ref] - [:object :sync-main-innercopy-0 :shapes] - [:object :sync-main-innercopy-0 :touched] - [:object :sync-main-innercopy-0 :width] - [:object :sync-main-innercopy-0 :height] - [:object :sync-main-innercopy-0 :selrect] - [:object :sync-main-innercopy-1 :width] - [:object :sync-main-innercopy-1 :height] - [:object :sync-main-innercopy-1 :selrect] - [:object :sync-main-innercopy-2 :width] - [:object :sync-main-innercopy-2 :height] - [:object :sync-main-innercopy-2 :selrect] - [:object :unlabelled :component-id] - [:object :unlabelled :shapes] - [:object :unlabelled :missing] - [:object :unlabelled :extra]}) - -(def ^:private level-1-reflow-left - ;; what one undo of a first step at level 1 leaves in place - #{[:object :unlabelled :component-id] - [:object :unlabelled :shape-ref] - [:object :unlabelled :shapes] - [:object :unlabelled :touched] - [:object :unlabelled :missing] - [:object :unlabelled :extra] - [:object :sync-main-innercopy-1 :width] - [:object :sync-main-innercopy-1 :height] - [:object :sync-main-innercopy-1 :selrect] - [:object :sync-main-innercopy-2 :width] - [:object :sync-main-innercopy-2 :height] - [:object :sync-main-innercopy-2 :selrect]}) - -(defn- first-steps-break-undo - "Known failures of the frontend round trip for the sweeps over `steps`, the - optional steps at levels 0, 1 and 2: the first of them to run at level 0 or - 1 reflows the nested frames, and that reflow lands in undo entries of its - own (F43), so one undo does not revert the whole step." - [steps] - (let [mark (fn [op pred left entries] - {:bug "F43" - :fails {:undo left - :undo-index #{[:undo-index entries]}} - :op op - :runners #{:frontend} - :when pred})] - [(mark (nth steps 0) (constantly true) level-0-reflow-left 5) - (mark (nth steps 1) #(not (tm/applied? % (nth steps 0))) level-1-reflow-left 2)])) +(defn- expected-level-color + "The color at nesting level `i` after the optional per-level `steps` (swaps + or switches; step j gives `swap-colors` j): a step at level j reaches + every level from j outwards, so it is the color of the applied step at + the highest j <= i, else the base color." + [s steps i] + (or (some #(when (tm/applied? s (nth steps %)) (nth swap-colors %)) + (range i -1 -1)) + base-color)) (defn swap-scenarios - "Case L. SWAP SWEEP — build a 3-level nesting, then OPTIONALLY swap the - nested component at each level for a differently-coloured one, and assert - the colour that surfaces at every level. A swap at level i propagates to - level i and every OUTER (higher-index) level, until a swap at a higher level - overrides it. So the colour at level i is the swap at the HIGHEST index - j <= i that was applied, else the base colour." + "Case L. A three-level nesting optionally swaps the nested component at + each level for one of its own colour. Each level shows the colour of + `expected-level-color`." [] (let [m "main" targets ["s0" "s1" "s2"] - ;; swap[i] swaps level i's nested component for target lineage i (color i) - swaps (mapv (fn [i] (n/swap-component m i (nth targets i))) (range 3)) - expected-at - (fn [s i] - ;; the colour of the applied swap at the highest j <= i, else base - (or (some (fn [j] (when (tm/applied? s (nth swaps j)) (nth swap-colors j))) - (range i -1 -1)) - base-color))] - {:setup setup/empty-situation - :undo-check {:known-failures (first-steps-break-undo swaps)} - :operation (tm/in-sequence - (concat - [(n/create-component m base-color)] - ;; a target lineage per level - (map-indexed (fn [i c] (n/create-component (nth targets i) c)) swap-colors) - [(n/make-nested-component m) (n/make-nested-component m) (n/make-nested-component m)] - ;; optionally swap at each level - (map (fn [sw] (tm/optional sw)) swaps) - [(tm/test-that - (fn [s] - (doseq [i (range 3)] - (t/is (= (expected-at s i) (level-color s m i)) - (str "level " i)))))]))})) + ;; swap i swaps level i for lineage i, of colour i + swaps (mapv (fn [i] (n/swap-component m i (nth targets i))) (range 3))] + {:setup setup/empty-situation + :operation (tm/in-sequence + (concat + [(n/create-component m base-color :size 100)] + (map-indexed (fn [i c] (n/create-component (nth targets i) c :size 100)) + swap-colors) + [(n/make-nested-component m) (n/make-nested-component m) (n/make-nested-component m)] + (map (fn [sw] (tm/optional sw)) swaps) + [(tm/test-that + (fn [s] + (doseq [i (range 3)] + (t/is (= (expected-level-color s swaps i) (level-color s m i)) + (str "level " i)))))]))})) (defn variant-switch-scenarios - "Case M. VARIANT-SWITCH SWEEP — the variant-switch flavour of case L. Build - a variant SET of peer members and nest the base member at EVERY level (so - each level has a variant head, just as case L's swap target exists at every - level). Then OPTIONALLY switch the variant head at each level to a - differently-coloured sibling and assert the colour that surfaces at every - level. A variant switch is a keep-touched swap, so it propagates like case - L: the colour at level i is the switch at the HIGHEST index j <= i that was - applied, else the base member's colour." + "Case M. Case L with variant switches: a variant member nested and wrapped + twice, so every level holds its image, and an optional switch at each + level to a member of its own colour." [] (let [m "main" ; the nesting lineage (holds the nesting-data) vset "vset" ; the variant set - vals ["v0" "v1" "v2" "v3"] + values ["v0" "v1" "v2" "v3"] colors (into [base-color] swap-colors) ; base + sibling colours - ;; switch[i] switches level i's variant head to member i+1 (colour i). The - ;; single variant instance has a corresponding (switchable) head at every - ;; level — `nested-head` IS the deepest instance there — so we can switch at - ;; ANY level, exactly like case L's per-level swap. - switches (mapv (fn [i] (n/switch-variant (n/nested-head-of m i) (nth vals (inc i)))) - (range 3)) - expected-at - (fn [s i] - ;; same precedence as case L - (or (some (fn [j] (when (tm/applied? s (nth switches j)) (nth swap-colors j))) - (range i -1 -1)) - base-color))] - {:setup setup/empty-situation - :undo-check {:known-failures (first-steps-break-undo switches)} - :operation (tm/in-sequence - (concat - ;; the nesting lineage, and the variant set (members = [value color]) - [(n/create-component m base-color) - (n/make-variant-container vset (mapv vector vals colors))] - ;; introduce the variant instance ONCE (innermost), then wrap it - ;; with plain nesting so each outer level CONTAINS the one below - ;; (progressive nesting, like case L). nested-head at every level - ;; is then the variant (the deepest instance), so a switch at - ;; level i targets it and propagates OUTWARD — exactly like case - ;; L's swap. - [(n/make-nested-component-with-variant m vset "v0") - (n/make-nested-component m) - (n/make-nested-component m)] - ;; optionally switch each level's variant head to its target sibling - (map (fn [sw] (tm/optional sw)) switches) - [(tm/test-that - (fn [s] - (doseq [i (range 3)] - (t/is (= (expected-at s i) (level-color s m i)) - (str "level " i)))))]))})) + ;; switch i switches level i to member i+1, of colour i + switches (mapv (fn [i] (n/switch-variant (n/nested-head-of m i) (nth values (inc i)))) + (range 3))] + {:setup setup/empty-situation + :operation (tm/in-sequence + (concat + [(n/create-component m base-color :size 100) + (n/make-variant-container vset (mapv vector values colors) :size 100)] + ;; each outer level holds the one below, so a switch + ;; reaches the outer levels + [(n/make-nested-component-with-variant m vset "v0") + (n/make-nested-component m) + (n/make-nested-component m)] + (map (fn [sw] (tm/optional sw)) switches) + [(tm/test-that + (fn [s] + (doseq [i (range 3)] + (t/is (= (expected-level-color s switches i) (level-color s m i)) + (str "level " i)))))]))})) (defn variant-switch-keeps-override-only-where-mains-agree "Case O. A copy overrides the fill of its nested variant's rect, then the @@ -444,7 +355,7 @@ (t/is (n/has-property-of override rect)) (t/is (contains? (:touched rect) :fill-group))) (do - (t/is (= red (-> rect :fills first :fill-color))) + (t/is (= red (fill-color rect))) (t/is (not (contains? (:touched rect) :fill-group)))))))})) (defn detach-keeps-nested-copies-linked @@ -458,65 +369,30 @@ remote main." [] (let [m "main" - nest-1 (n/make-nested-component m) - nest-2 (n/make-nested-component m) change-main (n/change-property (n/main-rect-of m) :fills green) - change-remote (n/change-property (n/remote-rect-of m) :fills blue) - ;; at depth 2 the sync of the remote change reflows the nested - ;; frames, and the reflow lands in an undo entry of its own (F43) - reflow-mark (fn [main? left entries] - {:bug "F43" - :fails {:undo left - :undo-index #{[:undo-index entries]}} - :op change-remote - :runners #{:frontend} - :when #(and (tm/applied? % nest-1) - (tm/applied? % nest-2) - (= main? (tm/applied? % change-main)))})] - {:setup setup/empty-situation - :undo-check {:known-failures - [(reflow-mark true - #{[:object :sync-main-innercopy-0 :width] - [:object :sync-main-innercopy-0 :height] - [:object :sync-main-innercopy-0 :selrect] - [:object :sync-main-rect :fills] - [:object :unlabelled :fills]} - 2) - (reflow-mark false - #{[:object :sync-main-innercopy-0 :width] - [:object :sync-main-innercopy-0 :height] - [:object :sync-main-innercopy-0 :selrect] - [:object :sync-main-innercopy-1 :width] - [:object :sync-main-innercopy-1 :height] - [:object :sync-main-innercopy-1 :selrect] - [:object :sync-main-copyhead-0 :width] - [:object :sync-main-copyhead-0 :height] - [:object :sync-main-copyhead-0 :selrect] - [:object :sync-main-rect :fills] - [:object :unlabelled :fills]} - 3)]} - :operation (tm/in-sequence - [(n/create-component m red) - (tm/optional nest-1) - (tm/optional nest-2) - (n/instantiate-copy m) - (tm/optional change-main) - (n/detach (n/copy-head-of m)) - change-remote]) - :asserter (fn [s] - (let [rect (tm/shape-by-id s (n/lineage-copy-rect s m)) - color (-> rect :fills first :fill-color) - nested? (or (tm/applied? s nest-1) (tm/applied? s nest-2)) - main? (tm/applied? s change-main)] - (if nested? - (do - (t/is (some? (:shape-ref rect))) - (t/is (= (if main? green blue) color)) - (t/is (= main? (contains? (:touched rect) :fill-group)))) - (do - (t/is (nil? (:shape-ref rect))) - (t/is (nil? (:touched rect))) - (t/is (= (if main? green red) color))))))})) + change-remote (n/change-property (n/remote-rect-of m) :fills blue)] + {:setup setup/empty-situation + :operation (tm/in-sequence + [(n/create-component m red :size 100) + (depth-sweep m) + (n/instantiate-copy m) + (tm/optional change-main) + (n/detach (n/copy-head-of m)) + change-remote]) + :asserter (fn [s] + (let [rect (tm/shape-by-id s (n/lineage-copy-rect s m)) + color (fill-color rect) + nested? (pos? (n/nesting-depth s m)) + main? (tm/applied? s change-main)] + (if nested? + (do + (t/is (some? (:shape-ref rect))) + (t/is (= (if main? green blue) color)) + (t/is (= main? (contains? (:touched rect) :fill-group)))) + (do + (t/is (nil? (:shape-ref rect))) + (t/is (nil? (:touched rect))) + (t/is (= (if main? green red) color))))))})) (defn update-main-reaches-other-copies "Case R. A component at nesting depth 0, 1 or 2 has two copies. The first @@ -528,14 +404,11 @@ the main when it had none." [] (let [m "main" - nest-1 (n/make-nested-component m) - nest-2 (n/make-nested-component m) other-override (n/change-property (n/nth-copy-rect-of m 1) :fills blue)] {:setup setup/empty-situation :operation (tm/in-sequence [(n/create-component m red) - (tm/optional nest-1) - (tm/optional nest-2) + (depth-sweep m) (n/instantiate-copy m) (n/instantiate-copy m) (tm/optional other-override) @@ -543,18 +416,17 @@ (n/update-main (n/nth-copy-head-of m 0))]) :asserter (fn [s] (let [rect (fn [id] (tm/shape-by-id s id)) - color (fn [shape] (-> shape :fills first :fill-color)) fill? (fn [shape] (contains? (:touched shape) :fill-group)) - nested? (or (tm/applied? s nest-1) (tm/applied? s nest-2)) + nested? (pos? (n/nesting-depth s m)) other? (tm/applied? s other-override) main (rect (n/lineage-rect s m)) copy-0 (rect (n/lineage-nth-copy-rect s m 0)) copy-1 (rect (n/lineage-nth-copy-rect s m 1))] - (t/is (= green (color main))) + (t/is (= green (fill-color main))) (t/is (= nested? (fill? main))) - (t/is (= green (color copy-0))) + (t/is (= green (fill-color copy-0))) (t/is (not (fill? copy-0))) - (t/is (= (if other? blue green) (color copy-1))) + (t/is (= (if other? blue green) (fill-color copy-1))) (t/is (= other? (fill? copy-1)))))})) (defn deleted-component-copies-sync-again-after-restore @@ -568,8 +440,7 @@ (let [override (n/change-property :copy-instance :fills green) first-change (n/change-property :main-instance :fills red) deletion (n/delete-component :main-root) - second-change (n/change-property :main-instance :fills blue) - color (fn [shape] (-> shape :fills first :fill-color))] + second-change (n/change-property :main-instance :fills blue)] {:setup setup/simple-component-with-copies-on-two-pages :operation (tm/in-sequence [(tm/optional override) @@ -581,16 +452,16 @@ other (setup/other-page-copy-instance s)] (t/is (some? (:shape-ref copy))) (t/is (some? (:shape-ref other))) - (t/is (= (if (tm/applied? s override) green red) (color copy))) - (t/is (= red (color other)))))) + (t/is (= (if (tm/applied? s override) green red) (fill-color copy))) + (t/is (= red (fill-color other)))))) (n/restore-component deletion) second-change]) :asserter (fn [s] (let [copy (setup/copy-instance s) other (setup/other-page-copy-instance s)] - (t/is (= blue (color (setup/main-instance s)))) - (t/is (= (if (tm/applied? s override) green blue) (color copy))) - (t/is (= blue (color other))) + (t/is (= blue (fill-color (setup/main-instance s)))) + (t/is (= (if (tm/applied? s override) green blue) (fill-color copy))) + (t/is (= blue (fill-color other))) (t/is (nil? (:touched other)))))})) (defn duplicated-copy-keeps-overrides-and-link @@ -607,8 +478,7 @@ {:setup setup/empty-situation :operation (tm/in-sequence [(n/create-component m red) - (tm/optional (n/make-nested-component m)) - (tm/optional (n/make-nested-component m)) + (depth-sweep m) (n/instantiate-copy m) (tm/optional override) duplication @@ -619,9 +489,9 @@ copy-rect (tm/shape-by-id s (n/lineage-copy-rect s m)) expected (if (tm/applied? s override) green blue)] (t/is (some? (:shape-ref dup-rect))) - (t/is (= expected (-> dup-rect :fills first :fill-color))) + (t/is (= expected (fill-color dup-rect))) (t/is (= (:touched copy-rect) (:touched dup-rect))) - (t/is (= expected (-> copy-rect :fills first :fill-color)))))})) + (t/is (= expected (fill-color copy-rect)))))})) (defn nested-copy-reaches-copies-of-the-receiving-main "Case U. A copy of an inner component is moved into the main of an outer @@ -652,14 +522,14 @@ :asserter (fn [s] (let [moved (tm/shape-by-id s (n/lineage-copy-rect s inner)) nested (tm/shape-by-id s (nested-rect s))] - (t/is (= blue (-> moved :fills first :fill-color))) + (t/is (= blue (fill-color moved))) (t/is (nil? (:touched moved))) (if (tm/applied? s override) (do - (t/is (= green (-> nested :fills first :fill-color))) + (t/is (= green (fill-color nested))) (t/is (contains? (:touched nested) :fill-group))) (do - (t/is (= blue (-> nested :fills first :fill-color))) + (t/is (= blue (fill-color nested))) (t/is (nil? (:touched nested)))))))})) (defn new-edit-after-undo-clears-redo @@ -687,14 +557,11 @@ with the minimal one, the frontend reflows after the remote change land in undo entries of their own (F43), so three undos stop short." [] - (let [m "main" - rect (fn [s id] (tm/shape-by-id s id)) - colour (fn [shape] (-> shape :fills first :fill-color))] + (let [m "main"] {:setup setup/empty-situation :operation (tm/in-sequence [(n/create-component m red :size 100) - (tm/optional (n/make-nested-component m)) - (tm/optional (n/make-nested-component m)) + (depth-sweep m) (n/instantiate-copy m) (n/change-property (n/remote-rect-of m) :fills blue) (n/change-property (n/main-rect-of m) :fills green) @@ -704,8 +571,9 @@ (doseq [id [((n/remote-rect-of m) s) ((n/main-rect-of m) s) (n/lineage-copy-rect s m)]] - (t/is (= red (colour (rect s id)))) - (t/is (empty? (:touched (rect s id))))))})) + (let [rect (tm/shape-by-id s id)] + (t/is (= red (fill-color rect))) + (t/is (empty? (:touched rect))))))})) (defn undo-before-sync-leaves-copies-unchanged "Case X (frontend only). An edit to the main is undone in the same step, so @@ -713,14 +581,40 @@ to its state before the edit: the main and its copy show the first value and the copy is untouched." [] - (let [original (n/change-property :main-instance :fills "#abcdef")] - {:setup setup/simple-component-with-labeled-copy - :operation (tm/in-sequence [(n/undo-before-sync :main-instance :fills red)]) - :asserter (fn [s] - (let [copy (setup/copy-instance s)] - (t/is (n/has-property-of original (setup/main-instance s))) - (t/is (n/has-property-of original copy)) - (t/is (nil? (:touched copy)))))})) + {:setup setup/simple-component-with-labeled-copy + :operation (tm/in-sequence [(n/undo-before-sync :main-instance :fills red)]) + :asserter (fn [s] + (let [copy (setup/copy-instance s)] + (t/is (= setup/labeled-fill (fill-color (setup/main-instance s)))) + (t/is (= setup/labeled-fill (fill-color copy))) + (t/is (nil? (:touched copy)))))}) + +(defn reflow-after-nested-sync-is-its-own-undo-step + "Case AJ (frontend only). A component nested two levels deep, with the + minimal frame size, has a copy; its remote main changes the rect, then one + undo runs. The transform math rewrites the minimal nested frames with float + noise, so the sync of the change reflows them, and the reflow commits land + in undo entries of their own (F43). One undo should revert the change and + its sync; it reverts only the last reflow entry, so the remote rect keeps + the change. How many entries the reflow makes depends on when its 100 ms + buffer flushes, so the case checks the value one undo leaves, never the + undo stack." + [] + (let [m "main" + remote (n/remote-rect-of m)] + {:setup setup/empty-situation + ;; the round trip's signature depends on when the reflow buffer flushes + :undo-check {:off "the case undoes its own step (F43)"} + :operation (tm/in-sequence + [(n/create-component m red) + (n/make-nested-component m) + (n/make-nested-component m) + (n/instantiate-copy m) + (n/change-property remote :fills blue) + (n/undo)]) + :asserter (fn [s] + (tm/known-failure "F43" red blue + (fill-color (tm/shape-by-id s (remote s)))))})) (defn text-override-merges-with-main-text-change "Case Y. A main text changes its characters or its font size; before that, @@ -767,11 +661,10 @@ ;; --------------------------------------------------------------------------- ;; Swap outcomes ;; -;; What a swap must give, asserted on values and structure rather than on how -;; the swap is stored, so the cases hold across the swap model change of the -;; plan's Phase 2b. Each builds a component "main" whose main nests a copy of -;; it once (level 0), and a copy of that, whose nested head the case swaps. -;; Real sizes keep the frontend reflows out of the undo entries (F43). +;; What a swap must give, asserted on values and structure, not on how the +;; swap is stored. Each case builds a component "main" whose main nests a +;; copy once, and a copy of it, whose nested head the case swaps. Real sizes +;; keep the frontend reflows out of the undo entries (F43). ;; --------------------------------------------------------------------------- (defn- head-component @@ -786,7 +679,7 @@ (->> (cfh/get-children-ids objects (head s)) (map #(get objects %)) (d/seek #(= :rect (:type %))) - :fills first :fill-color))) + (fill-color)))) (defn copy-swap-survives-main-changes "Case AA. A copy swaps its nested copy for another component. Optionally the @@ -876,20 +769,10 @@ pushes the copy's component: the main's nested copy becomes an instance of it, and so does the second copy's." [] - (let [m "main" - main-nst (fn [s] (:nested-head (n/lineage-nesting s m 0))) - second (fn [s] - (let [objects (:objects (thf/current-page (tm/file s))) - head ((n/nth-copy-head-of m 1) s)] - (->> (cfh/get-immediate-children objects head) - (d/seek :component-id) - :id))) - nested (fn [s] - (let [objects (:objects (thf/current-page (tm/file s))) - head ((n/nth-copy-head-of m 0) s)] - (->> (cfh/get-immediate-children objects head) - (d/seek :component-id) - :id)))] + (let [m "main" + main-nested (n/nested-head-under (n/main-head-of m)) + first-nested (n/nested-head-under (n/nth-copy-head-of m 0)) + second-nested (n/nested-head-under (n/nth-copy-head-of m 1))] {:setup setup/empty-situation :operation (tm/in-sequence [(n/create-component m base-color :size 100) @@ -897,20 +780,13 @@ (n/make-nested-component m) (n/instantiate-copy m) (n/instantiate-copy m) - (n/swap-shape nested "s1") + (n/swap-shape first-nested "s1") (n/update-main (n/nth-copy-head-of m 0))]) :asserter (fn [s] - (let [s1 (n/lineage-component-id s "s1") - main-head (fn [s] - (let [objects (:objects (thf/current-page (tm/file s))) - outer (:main-head (n/lineage-nesting s m 0))] - (->> (cfh/get-immediate-children objects outer) - (d/seek :component-id) - :id)))] - (t/is (some? (main-nst s))) - (t/is (= s1 (head-component s main-head))) - (t/is (= s1 (head-component s second))) - (t/is (= red (head-rect-color s second)))))})) + (let [s1 (n/lineage-component-id s "s1")] + (t/is (= s1 (head-component s main-nested))) + (t/is (= s1 (head-component s second-nested))) + (t/is (= red (head-rect-color s second-nested)))))})) (defn detached-or-duplicated-swapped-copy-follows-its-component "Case AE. A copy swaps its nested copy; then the copy is detached, or @@ -921,11 +797,7 @@ (let [m "main" nested (n/nested-head-in m) duplication (n/duplicate (n/copy-head-of m)) - dup-nested (fn [s] - (let [objects (:objects (thf/current-page (tm/file s)))] - (->> (cfh/get-immediate-children objects ((n/duplicate-head-of duplication) s)) - (d/seek :component-id) - :id)))] + dup-nested (n/nested-head-under (n/duplicate-head-of duplication))] {:setup setup/empty-situation :operation (tm/in-sequence [(n/create-component m base-color :size 100) @@ -964,7 +836,7 @@ (t/is (= 3 (column s :copy-root :copy-child)))))})) (defn main-reorder-keeps-copy-sub-heads-aligned - "Case AG (port of the plugin's MainReorderKeepsCopySlots). A main holds three + "Case AG (the plugin's MainReorderKeepsCopySlots). A main holds three nested copies side by side; it moves the first to the end. The copy follows: each of its children references the main's child at the same position." [] @@ -980,7 +852,7 @@ (t/is (= [] (setup/misaligned-sub-heads s))))})) (defn copy-sub-head-delete-keeps-others-aligned - "Case AH (port of the plugin's CopySubheadDeletePreservesSlots, without its + "Case AH (the plugin's CopySubheadDeletePreservesSlots, without its reflow). A grid main holds three nested copies; its copy optionally deletes its first or its last one. The copy's remaining children still reference the main's children at the same positions." @@ -992,7 +864,7 @@ (t/is (= [] (setup/misaligned-sub-heads s))))}) (defn copy-sub-head-delete-and-reflow-keeps-others-aligned - "Case AI (frontend only; port of the plugin's CopySubheadDeletePreservesSlots + "Case AI (frontend only; the plugin's CopySubheadDeletePreservesSlots with its reflow). As case AH, then the copy root optionally changes height, which reflows its grid. The copy's remaining children still reference the main's children at the same positions." @@ -1005,24 +877,17 @@ (t/is (= [] (setup/misaligned-sub-heads s))))}) (defn geometry-sync-with-rotated-instances - "Case N. Regression sweep for #10109, with #13267's semantics as its - complement: an instance root's transformation is inherited, overridable - content — asymmetric to position, which is free per-instance placement. - - On the simple component-with-copy, sweep three axes: optionally rotate the - COPY as a whole (an override of its root's placement — must not block - propagation), optionally rotate the MAIN as a whole (inherited content — an - untouched copy must follow it), and apply ONE of a property edit (fills) or - a geometry edit (height) to the main child. In EVERY variant the chosen edit - must arrive at the copy child; the copy's rotation is its own 45° if the - copy was rotated (override wins), else the main's 45° if the main was - rotated (clean copy follows), else 0; and only a rotated copy's ROOT is - touched (:geometry-group) — its child merely follows and stays untouched." + "Case N (frontend only). Optionally the copy rotates, optionally the main + rotates, then the main child changes its fill or its height. The change + reaches the copy child. A copy root's rotation is inherited content that a + copy may override: the copy shows its own rotation, else the main's, else + none. Only a rotated copy root is touched (:geometry-group); its child + follows untouched." [] (let [rotate-copy (n/rotate :copy-root 45) rotate-main (n/rotate :main-root 45) edits (tm/one-of - [(n/change-attr :main-instance :fills red) + [(n/change-property :main-instance :fills red) (n/change-height :main-instance 80)])] {:setup setup/simple-component-with-labeled-copy :operation (tm/in-sequence [(tm/optional rotate-copy) @@ -1036,19 +901,16 @@ (tm/applied? situation rotate-copy) 45 (tm/applied? situation rotate-main) 45 :else 0)] - ;; the chosen main edit arrived at the copy child, in every variant (t/is (some? chosen)) (t/is (n/has-property-of chosen copy-child)) - ;; the copy shows the expected rotation (own override > followed main > none) (t/is (mth/close? (or (:rotation copy-root) 0) expected-rotation)) (t/is (mth/close? (or (:rotation copy-child) 0) expected-rotation)) - ;; only a rotated copy's ROOT is an override; the child merely follows (t/is (= (if (tm/applied? situation rotate-copy) #{:geometry-group} nil) (:touched copy-root))) (t/is (nil? (:touched copy-child)))))})) (defn main-child-move-reaches-copies - "Case Z (frontend only, like the other geometry operations). A child of the + "Case Z (frontend only). A child of the main moves; optionally the copy moved its own child before. The copy child keeps its offset from the copy root equal to the main child's from the main root, so it follows the move, unless it moved itself: then it keeps its own @@ -1075,11 +937,9 @@ (t/is (empty? (:touched (setup/copy-root s))))))})) (defn touched-copy-child-survives-main-rotation - "A copy whose ROOT is rotated (a geometry override) AND whose CHILD has its - own geometry override (resized) must keep the child exactly in place when - the MAIN is later rotated: the child's placement is its own, shielded by its - touched :geometry-group. We capture the child's position relative to the - copy root before the main rotation and assert it is unchanged after." + "Frontend only. A copy rotates its root and resizes its child, then the + main rotates. The child's touched :geometry-group shields it: its height + and its position relative to the copy root do not change." [] (let [before (atom nil) rel-pos (fn [situation] @@ -1098,11 +958,8 @@ (let [copy-child (setup/copy-instance situation) copy-root (setup/copy-root situation) after (rel-pos situation)] - ;; both overrides are recorded as geometry touches (t/is (contains? (:touched copy-root) :geometry-group)) (t/is (contains? (:touched copy-child) :geometry-group)) - ;; the child keeps its own overridden height (t/is (mth/close? (:height copy-child) 60)) - ;; and its position relative to the copy root is unchanged by the main rotation (t/is (mth/close? (:x @before) (:x after) 0.5) (str "rel-x " (:x @before) " -> " (:x after))) (t/is (mth/close? (:y @before) (:y after) 0.5) (str "rel-y " (:y @before) " -> " (:y after)))))})) diff --git a/common/src/app/common/test_helpers/composable/comp/nodes.cljc b/common/src/app/common/test_helpers/composable/comp/nodes.cljc index 703e2310ca..c8b0c28794 100644 --- a/common/src/app/common/test_helpers/composable/comp/nodes.cljc +++ b/common/src/app/common/test_helpers/composable/comp/nodes.cljc @@ -5,23 +5,10 @@ ;; Copyright (c) KALEIDOS SUBSIDIARY SL (ns app.common.test-helpers.composable.comp.nodes - "Component-specific operation nodes for the test model. - - These are the `IOperation` implementations whose subject is Penpot component - behaviour: they wrap component/shape operations and drive the real production - change pipeline. This namespace sits behind the `comp` boundary precisely - because it is about components; the generic engine in - `app.common.test-helpers.composable.core` has no domain terms. See - `mem:frontend/composable-component-tests`. - - Nodes deliberately call the production change pipeline directly - (`cls/generate-update-shapes` + `thf/apply-changes`, - `cll/generate-sync-file-changes` + `thf/apply-changes`) in the same way the - existing `app.common.test-helpers.compositions` helpers do. - - Each node, on apply, records a self-description into the situation's applied-log - so conditions (and later undo) can read back what it did, keeping the - operation the single source of truth for what should hold." + "The component operations of the composable test model (see + `mem:frontend/composable-component-tests`). Each builds its changes with + the production generators, applies them to the file and records what it + did under its identity." (:require [app.common.data :as d] [app.common.files.changes-builder :as pcb] @@ -45,25 +32,14 @@ [app.common.types.text :as txt])) ;; --------------------------------------------------------------------------- -;; Operation kinds and the production changes of user operations -;; -;; Every component node declares its kind, which tells a runner how to treat -;; it: -;; :assembly builds the configuration with test helpers; no sync, no -;; undo group, and it records no changes. -;; :user a user action the app commits. It stores the production -;; changes it applied with `record-changes` (nil when it -;; changed nothing). The pure runner -;; (`app.common.test-helpers.composable.comp.runner`) takes -;; them to sync the file and to build its undo stack. -;; :undo reverts the latest user action; needs a runner's undo -;; stack. -;; :redo applies again the latest reverted user action; needs a -;; runner's redo stack. -;; :frontend-only its production result needs frontend code; the pure -;; runner rejects it. -;; The pure runner checks that a :user node recorded its changes and that -;; no other kind did. +;; Operation kinds: how a runner treats a node. +;; :assembly builds the configuration with test helpers: no sync, no +;; undo group, no recorded changes. +;; :user a user action; records the changes it applied with +;; `record-changes` (nil when it changed nothing), which +;; the pure runner syncs from and pushes as an undo group. +;; :undo, :redo need a runner's undo or redo stack. +;; :frontend-only needs frontend code; the pure runner rejects it. ;; --------------------------------------------------------------------------- (defprotocol IComponentOperation @@ -80,9 +56,7 @@ (defprotocol IAppliedResult (applied-result [op file-before file-after] "A map of what `op` did that its accessors need, read from the file before - and after it. Both runners record it with the op's application: the pure - node in `apply-to`, the frontend interpreter after the op's event - settles.")) + and after it. Both runners record it with the op's application.")) (defn take-changes "The changes recorded by the last operation and the situation without them, @@ -94,21 +68,14 @@ (dissoc situation ::changes)]) ;; --------------------------------------------------------------------------- -;; Properties — an OPEN, extensible vocabulary of "what about a shape can change" -;; -;; A property is named by a keyword (`:fills`, `:opacity`, … extensible to -;; `:text`). Two pure functions know how to WRITE a property onto a shape (the -;; edit) and how to READ its comparable value back (the check). `change-property` -;; (the edit operation) uses `set-property`; `has-property-of` (the inspection) -;; uses `read-property` — so the change and its check stay duals, and adding a new -;; property kind is one clause in each `case`. (`change-attr`/`has-attr?` remain as -;; aliases for the common `:fills`/`:opacity` use.) +;; Properties: `set-property` writes one onto a shape (`change-property`) +;; and `read-property` reads it back (`has-property-of`). A new property is +;; one clause in each. ;; --------------------------------------------------------------------------- (defn set-property - "Write `property` = `value` onto `shape`, returning the updated shape. The edit - half of a property; extend the `case` to support more properties. Public so the - frontend interpreter applies the IDENTICAL edit the common node does." + "`shape` with `property` set to `value`. Public so the frontend interpreter + makes the same edit." [shape property value] (case property :fills (assoc shape :fills (ths/sample-fills-color :fill-color value)) @@ -118,8 +85,7 @@ {:property property})))) (defn- read-property - "Read the comparable value of `property` from `shape`. The check half of a - property; extend the `case` to support more properties." + "The comparable value of `property` in `shape`." [shape property] (case property :fills (-> shape :fills first :fill-color) @@ -134,12 +100,7 @@ tm/IOperation (apply-to [this situation] - ;; Goes through the production change path, exactly like tho/update-color, - ;; then records under its own identity. (let [the-file (tm/file situation) - ;; `target` may be a ROLE (resolved via the situation, so the edit - ;; FOLLOWS the role as state-building ops like make-nested-component re-point it) - ;; or a label; strict-presence throws if neither resolves. shape-id (tm/target-shape-id situation target) page (thf/current-page the-file) changes (cls/generate-update-shapes @@ -155,26 +116,18 @@ (tm/record-application this {:target target :property property :value value}))))) (defn change-property - "Constructor for the property-change operation: change `property` of the shape - named by `target` (a role or a label) to `value`. Stamps a node identity so the - test can interrogate it (via `has-property-of`). The general form; `change-attr` - is the same thing for the common `:fills`/`:opacity` properties." + "Constructor for the property-change operation: set `property` of the shape + `target` names (a role, a label or a `(situation -> id)` fn) to `value`." [target property value] (tm/assign-id (->ChangeProperty target property value))) -(def ^{:doc "Alias of `change-property` (the historical name for :fills/:opacity - changes). `[target attr value]`."} - change-attr change-property) - (defprotocol IPropertyCheck - "Inspection capability of a property-changing operation: report on its OWN - effect, applied to a shape the caller supplies. Makes no judgment about which - shape — the test supplies that (e.g. `(role-shape s :copy-child-rect)`)." + "The check dual of an operation that changes a property: whether a shape the + test supplies holds the value the operation set." (applied-property [node] "The property this node changed.") (applied-value [node] "The value this node applied.") (has-property-of [node shape] - "True if `shape` carries this node's changed property at this node's applied - value. The node reports against its own change; the test chooses the shape.")) + "Whether `shape` holds this node's property at this node's value.")) (extend-type ChangeProperty IPropertyCheck @@ -183,21 +136,14 @@ (has-property-of [node shape] (= (:value node) (read-property shape (:property node))))) -;; Aliases for the historical `has-attr?` name (used by the earlier cases). -(def ^{:doc "Alias of `has-property-of`."} has-attr? has-property-of) -(def ^{:doc "Alias of `applied-property`."} applied-attr applied-property) - ;; --------------------------------------------------------------------------- ;; edit-text — edit the content of a text shape ;; -;; An edit of the first span of a text, either its characters (`:text`) or its -;; font size (`:font-size`), as the text editor commits it when the edit ends: -;; a new `:content`, and a new name when the text still has the name generated -;; from its old content, written through `generate-update-shapes`. On a copy -;; the content touches `:content-group` plus the text subgroup of the change -;; (`:text-content-text` or `:text-content-attribute`). The frontend -;; interpreter commits the same edit through the real -;; `v2-update-text-shape-content` event, as the editor does on blur. +;; An edit of the characters (`:text`) or font size (`:font-size`) of a text's +;; first span, as the text editor commits it when the edit ends: a new +;; `:content`, and a new name when the text still has the name generated from +;; its old content. The frontend interpreter commits it through +;; `v2-update-text-shape-content`, as the editor does on blur. ;; --------------------------------------------------------------------------- (def ^:private first-span [:content :children 0 :children 0 :children 0]) @@ -263,16 +209,10 @@ ;; --------------------------------------------------------------------------- ;; Geometry operations ;; -;; Unlike `change-property` (a raw attribute write), geometric changes must go -;; through the TRANSFORM pipeline: on the frontend, the interpreter dispatches -;; the real sidebar events (`dwt/increase-rotation`, `dwt/update-dimensions`), -;; whose apply-modifiers step also runs the placement-vs-override classification -;; for component copies (calculate-ignore-tree / check-delta) — which is part of -;; what these operations exist to exercise. The synchronous `apply-to` fallback -;; below performs the geometrically equivalent transform through the production -;; math, but cannot classify placement (that code is frontend-only), so cases -;; using these operations are meant to run through the interpreter. The pure -;; runner rejects them. +;; The frontend interpreter dispatches the real sidebar events, whose +;; transform step decides which copy shapes the change touches +;; (`check-delta`), frontend code. Their `apply-to` makes the same transform +;; without that step, so the pure runner rejects them. (defrecord Rotate [target angle] IComponentOperation @@ -285,7 +225,7 @@ page (thf/current-page the-file) objects (:objects page) shape (get objects shape-id) - ;; rotating a container rotates its whole subtree, as the real event does + ;; the whole subtree rotates, as with the real event ids (into #{shape-id} (cfh/get-children-ids objects shape-id)) center (gsh/shape->center shape) rotate1 (fn [s] (gsh/transform-shape s (ctm/rotation-modifiers s center angle))) @@ -301,10 +241,9 @@ (tm/record-application this {:target target :angle angle}))))) (defn rotate - "Constructor for the rotation operation: rotate the shape named by `target` - (a role, a label, or a `(situation -> id)` fn) — including its whole subtree — - by `angle` degrees around its center. On the frontend this dispatches the real - `dwt/increase-rotation` event." + "Constructor for the rotation operation: rotate the shape `target` names, + with its subtree, by `angle` degrees around its center + (`dwt/increase-rotation` on the frontend)." [target angle] (tm/assign-id (->Rotate target angle))) @@ -355,17 +294,15 @@ (tm/record-application this {:target target :dx dx :dy dy}))))) (defn move-shape - "Constructor for the move operation: move the shape named by `target` by - (`dx`, `dy`). On the frontend this dispatches the real sidebar - `dwt/update-position` event." + "Constructor for the move operation: move the shape `target` names by + (`dx`, `dy`) (`dwt/update-position` on the frontend)." [target dx dy] (tm/assign-id (->MoveShape target dx dy))) (defn change-height - "Constructor for the height-change operation: resize the shape named by `target` - to height `value` (width unchanged). On the frontend this dispatches the real - `dwt/update-dimensions` event. Implements `IPropertyCheck`, so a `one-of` over - property and geometry edits can assert uniformly via `has-property-of`." + "Constructor for the height-change operation: resize the shape `target` + names to height `value` (`dwt/update-dimensions` on the frontend). It has + `has-property-of`, like the property edits." [target value] (tm/assign-id (->ChangeHeight target value))) @@ -384,33 +321,18 @@ (= (:value node) (text-span-value shape (:edit node))))) ;; =========================================================================== -;; Synchronisation-scenario building blocks +;; Scenario building blocks ;; -;; A family of operations that build up a component/copy configuration STEP BY -;; STEP, tracking a small, explicit set of named things in the situation so that -;; later edits and assertions can refer to them regardless of how much nesting was -;; applied. The tracked things per lineage (see the "Component objects" block -;; below for the exact fields): -;; -;; - the REMOTE head/rect — the ORIGINAL instance and its rect (the fixed -;; deepest origin; never re-pointed by plain nesting), -;; - the MAIN head/rect — the CURRENT outer main and its rect (the shape an -;; edit-to-main targets; advances inward with each `make-nested-component`), -;; - the COPY head/rect — the copy produced by `instantiate-copy` and its rect -;; (the shape an edit-to-copy targets / assertions observe), -;; - the component id the next instantiate/nest uses, and the nesting count. -;; -;; "corresponds to" between layers is resolved by following the :shape-ref chain -;; (a copy shape refs the main shape it mirrors); within these single-file setups -;; the chain resolves in the local page objects, so a local walk suffices. +;; Operations that build a component configuration step by step and track +;; named lineages in the situation (see "Component lineages" below), so later +;; edits and assertions find their shapes at any nesting depth. A shape's +;; image in another layer is found by following the :shape-ref chain within +;; the page. ;; =========================================================================== (defn- ref-chain-ids - "The set of ids on `shape`'s :shape-ref chain within `objects`, INCLUDING the - shape's own id and every shape its :shape-ref transitively points at. So a copy - shape's chain contains the near-main it mirrors, that near-main's near-main, and - so on — letting us recognise the descendant that is the image of a given origin - shape regardless of how many layers sit between." + "The ids on `shape`'s :shape-ref chain within `objects`: its own, its near + main's, that one's near main's, and so on." [objects shape] (loop [s shape, acc #{}] (let [acc (conj acc (:id s))] @@ -419,9 +341,8 @@ acc)))) (defn- descendant-corresponding-to - "The id of the shape in `head-id`'s subtree that is the propagated image of - `target-id` — i.e. whose :shape-ref chain PASSES THROUGH `target-id`. Throws if - not found or ambiguous — a structural invariant of these setups." + "The id of the shape in `head-id`'s subtree whose :shape-ref chain passes + through `target-id`. Throws when there is none or more than one." [objects head-id target-id] (let [descendants (cfh/get-children-ids objects head-id) matches (filter (fn [id] @@ -435,57 +356,46 @@ {:head head-id :target target-id :matches matches}))))) (defn- self-or-descendant-corresponding-to - "Like `descendant-corresponding-to`, but considers `head-id` ITSELF as well as - its subtree. Needed for the nested HEAD: when the instance nested at a level is - directly the image of the origin instance (e.g. level 0, where the inner copy - head IS that image), the match is the head itself, not a descendant." + "Like `descendant-corresponding-to`, with `head-id` itself as a candidate." [objects head-id target-id] (if (contains? (ref-chain-ids objects (get objects head-id)) target-id) head-id (descendant-corresponding-to objects head-id target-id))) ;; =========================================================================== -;; Component objects — the situation tracks NAMED component lineages +;; Component lineages ;; -;; The sync/swap scenario operations track one or more COMPONENT LINEAGES, each an -;; addressable OBJECT under `:vars :components`, keyed by a name (e.g. "main"). This -;; replaces the earlier flat, single-lineage roles (:main-child-rect, …): grouping -;; one lineage's fields into one object (a) lets several lineages coexist — required -;; for swap, whose target is a *different* component — and (b) makes each operation -;; "read object `name`, update its fields, write it back". -;; -;; A component object has: -;; :main-component-id - the component to instantiate next for this lineage -;; (advances to the new OUTER component on make-nested-component) -;; :remote-head/:remote-rect - the fixed deepest origin (NEVER re-pointed) -;; :main-head/:main-rect - the current main (advances inward on make-nested-component) -;; :size - the size `create-component` gave the root (nil: minimal) +;; A lineage is a map under `:vars :components`, keyed by its name (e.g. +;; "main"); several can coexist, e.g. swap targets. It has: +;; :main-component-id the component to instantiate next (the new +;; outer one after `make-nested-component`) +;; :remote-head/:remote-rect the original main and its rect +;; :main-head/:main-rect the current outer main and the image of the +;; remote rect in it +;; :copy-head/:copy-rect the latest copy; all of them under :copies +;; :size the root size `create-component` got ;; :nesting-count -;; :nesting-data - vector, one entry per nesting level i, each: -;; {:main-head -;; :nested-head -;; :nested-rect -;; :nested-head-parent } -;; The PARENT is the swap-stable anchor: a swap replaces the head in place but -;; keeps its parent, so an assertion re-resolves parent -> current head -> rect. -;; -;; (Child shapes are addressed via the `*-rect` fields / `lineage-rect`; if other -;; child kinds are added later, they get parallel fields, not a restructure.) +;; :nesting-data per nesting level: :main-head (the level's +;; outer main), :nested-head (the copy nested at +;; that level), :nested-rect and +;; :nested-head-parent. A swap replaces the +;; head but keeps its parent, so accessors find +;; the current head through the parent. ;; =========================================================================== (defn- get-component-obj - "The component object named `name` from the situation (nil if absent)." + "The lineage `name`, or nil." [situation name] (get (tm/get-var situation :components {}) name)) (defn- put-component-obj - "Store/replace the component object named `name`." + "`situation` with the lineage `name` set to `obj`." [situation name obj] (tm/set-var situation :components (assoc (tm/get-var situation :components {}) name obj))) (defn- update-component-obj - "Apply `f` (obj -> obj) to the component object named `name`." + "`situation` with `f` applied to the lineage `name`." [situation name f] (put-component-obj situation name (f (get-component-obj situation name)))) @@ -504,13 +414,11 @@ [situation name i] (get-in (get-component-obj situation name) [:nesting-data i])) -;; Target helpers — return a (situation -> shape-id) fn for `change-property`'s -;; target (resolved at apply-time against the lineage object, so it follows the -;; current ids). `applied`-querying `Test`s read the same fields via the accessors -;; below. +;; Targets: `(situation -> shape id)` fns, resolved when the operation +;; applies, so they follow the lineage as it changes. (defn remote-rect-of - "Target: lineage `name`'s fixed remote (deepest-origin) rect." + "Target: lineage `name`'s remote rect." [name] (fn [s] (:remote-rect (get-component-obj s name)))) @@ -520,12 +428,12 @@ (fn [s] (:main-rect (get-component-obj s name)))) (defn copy-rect-of - "Target: lineage `name`'s current copy rect (from the latest instantiate-copy)." + "Target: lineage `name`'s latest copy rect." [name] (fn [s] (:copy-rect (get-component-obj s name)))) (defn copy-head-of - "Target: lineage `name`'s current copy head (from the latest instantiate-copy)." + "Target: lineage `name`'s latest copy head." [name] (fn [s] (:copy-head (get-component-obj s name)))) @@ -534,18 +442,28 @@ [name] (fn [s] (:main-head (get-component-obj s name)))) +(defn nested-head-under + "Target: the first nested copy head among the children of the shape the + target `parent` names. Found through the parent, so it still names the + head after a swap or switch replaced it in place." + [parent] + (fn [s] + (let [objects (:objects (thf/current-page (tm/file s)))] + (->> (cfh/get-immediate-children objects (tm/target-shape-id s parent)) + (d/seek :component-id) + (:id))))) + (defn nested-head-in "Target: the nested copy head directly inside lineage `name`'s current copy - head (the copy of a level-0 nesting). Found through its parent, so it - still names the head after a swap or switch replaced it in place." + head (the copy of a level-0 nesting)." [name] - (fn [s] - (let [objects (:objects (thf/current-page (tm/file s))) - head ((copy-head-of name) s)] - (->> (cfh/get-immediate-children objects head) - (filter :component-id) - (first) - (:id))))) + (nested-head-under (copy-head-of name))) + +(defn nested-head-of + "Target: the nested copy head introduced at lineage `name`'s nesting level + `i`, on the main side (`:nested-head` of that level)." + [name i] + (fn [s] (:nested-head (lineage-nesting s name i)))) (defn corresponding-shape-id "The id of the shape in `head-id`'s subtree (the head included) whose @@ -556,7 +474,7 @@ target-id)) (defn lineage-copy-rect - "The id of lineage `name`'s current copy rect (for assertions)." + "The id of lineage `name`'s latest copy rect." [situation name] (:copy-rect (get-component-obj situation name))) @@ -577,30 +495,16 @@ (defn level-rect "The id of the rect currently at lineage `name`'s nesting level `level`, - re-resolved from the swap-stable :nested-head-parent: parent -> current - subinstance head -> its rect descendant. Robust to a swap having replaced the - head (and the rect) in place." + found from the level's :nested-head-parent, so it holds after a swap + replaced the head (and the rect) in place." [situation name level] (let [objects (:objects (thf/current-page (tm/file situation))) - nd (lineage-nesting situation name level) - parent (:nested-head-parent nd) - head (->> (cfh/get-immediate-children objects parent) - (filter :component-id) - first - :id) - ;; the rect is the (single) rect descendant under the head - rect (->> (cfh/get-children-ids objects head) - (map #(get objects %)) - (filter #(= :rect (:type %))) - first - :id)] - rect)) - -(defn level-rect-of - "Target/accessor fn: the rect currently at lineage `name`'s nesting level - `level` (see `level-rect`)." - [name level] - (fn [s] (level-rect s name level))) + parent (:nested-head-parent (lineage-nesting situation name level)) + head ((nested-head-under (constantly parent)) situation)] + (->> (cfh/get-children-ids objects head) + (map #(get objects %)) + (d/seek #(= :rect (:type %))) + (:id)))) ;; --------------------------------------------------------------------------- ;; create-component — the starting operation: a component with a rect child @@ -630,7 +534,6 @@ comp-id (thi/id comp-label)] (-> situation (tm/with-file file') - ;; create the lineage object: remote == main at creation (no nesting yet) (put-component-obj name {:main-component-id comp-id :remote-head head-id :remote-rect rect-id @@ -641,55 +544,33 @@ (tm/record-application this {:component name :id comp-id}))))) (defn create-component - "Starting operation: create a component lineage named `name` (root frame + one - rect child of fill `color`) and track it as a component OBJECT. Sets - remote==main head+rect, :main-component-id, nesting-count 0. Begin a scenario - with this; create more lineages (e.g. swap targets) with further calls. - `:size` gives the root that width and height, and the rect half of it + "Create a component, a root frame with one rect of fill `color`, and track + it as lineage `name`. `:size` gives the root that width and height, and + the rect half of it (nesting gives the outer frames that size too); without it they all have the minimal default size." [name color & {:keys [size]}] (tm/assign-id (->CreateComponent name color size))) ;; --------------------------------------------------------------------------- -;; make-nested-component — wrap the tracked component in a NEW OUTER component +;; make-nested-component — wrap the lineage's component in a new outer one ;; -;; ONE specific notion of nesting (there are several): a new ENCLOSING component -;; whose main CONTAINS a COPY of the lineage's current component (contain-outward), -;; and the OUTER component becomes the lineage's new :main-component-id. The inner -;; copy's rect that corresponds (via :shape-ref) to the lineage's :remote-rect -;; becomes the new :main-rect, so an edit-to-main now targets one level deeper -;; while :remote-rect stays the fixed origin. Iterable: apply twice for 2 layers. -;; This is the structural family of penpot#9304 (a subinstance head inside a copy; -;; that issue adds a variant inner component + an extra frame — separate axes). +;; The new component's main holds a copy of the lineage's current component +;; and becomes the lineage's next component. The image of the remote rect in +;; that copy becomes the main rect, so edits to the main go one level deeper. +;; Apply it again for more levels. ;; --------------------------------------------------------------------------- (defn- nest-in-new-outer-component - "Shared nesting mechanism (contain-outward): add a fresh outer board, run - `instantiate-inner-fn` to place THE INNER INSTANCE inside it, turn the board - into a NEW OUTER component, then advance lineage `name`'s object (main -> - deeper rect, append a `nesting-data` entry with the swap-stable - :nested-head-parent, bump nesting-count) and record `op`. - - `instantiate-inner-fn` is `(file outer-frame-label inner-copy-label) -> file`: - it instantiates whatever is being nested (the lineage's own component, or a - chosen variant) into `outer-frame-label`, registering `inner-copy-label` as - the inner copy's root. - - `seek-rect-id` / `seek-head-id` are the ORIGIN rect and the ORIGIN instance head - whose IMAGES inside the new inner copy become this level's nested rect and nested - head — found by following the shape-ref chain. For nesting the lineage's own - component these are the lineage's :remote-rect / :remote-head; for nesting a - variant member they are THAT MEMBER's rect / root (the inner copy refs the member, - not the lineage). `nested-head` is thus the DEEPEST instance (the image of the - original component's instance), per spec — at level 0 it is the inner copy itself; - at deeper levels it is the corresponding shape nested within. Everything else is - identical across nesting flavours, so a new flavour supplies only these three." + "Add an outer board, place a copy in it with `instantiate-inner-fn` + (`(file outer-frame-label inner-copy-label) -> file`), make the board a + new component and advance lineage `name` one nesting level; record `op`. + The images, in the inner copy, of `seek-rect-id` and `seek-head-id` (the + original rect and head) become the level's nested rect and nested head." [situation name op seek-rect-id seek-head-id instantiate-inner-fn] (let [the-file (tm/file situation) obj (get-component-obj situation name) level (:nesting-count obj) - ;; level-scoped labels so repeated nestings of one lineage don't clash outer-frame (keyword (str "sync-" name "-outer-" level)) inner-copy (keyword (str "sync-" name "-innercopy-" level)) outer-comp (keyword (str "sync-" name "-outercomp-" level)) @@ -701,11 +582,7 @@ (thc/make-component outer-comp outer-frame)) objects (:objects (thf/current-page file')) inner-copy-id (thi/id inner-copy) - ;; images, inside the new inner copy, of the origin rect and origin instance new-main-rect (descendant-corresponding-to objects inner-copy-id seek-rect-id) - ;; nested-head = the DEEPEST instance (image of the original component's - ;; instance), per spec — the switchable subinstance. Its parent is the - ;; swap-stable anchor for re-resolving it after a swap/switch replaces it. nested-head (self-or-descendant-corresponding-to objects inner-copy-id seek-head-id) nested-parent (:parent-id (get objects nested-head)) outer-id (thi/id outer-comp) @@ -727,37 +604,43 @@ :nested-head-parent nested-parent})))) (tm/record-application op {:component name :level level :outer outer-id})))) -(defrecord MakeNestedComponent [name] +(defn- nest-once + "Wrap lineage `name`'s component once in a new outer component; record `op`." + [situation name op] + (let [obj (get-component-obj situation name)] + (nest-in-new-outer-component + situation name op + (:remote-rect obj) + (:remote-head obj) + (fn [file outer-frame inner-copy] + (let [inner-label (thi/label (:main-component-id obj))] + (thc/instantiate-component file inner-label inner-copy + {:parent-label outer-frame})))))) + +(defrecord MakeNestedComponent [name levels] IComponentOperation (op-kind [_] :assembly) tm/IOperation (apply-to [this situation] - ;; nest a COPY of the lineage's own current component. Seek the FIXED deepest - ;; origin (:remote-rect / :remote-head): every level's copy refs back through it, - ;; so its image identifies this level's nested rect and deepest instance. (Variant - ;; nesting re-points :remote-* to the variant member, keeping this uniform.) - (let [obj (get-component-obj situation name)] - (nest-in-new-outer-component - situation name this - (:remote-rect obj) - (:remote-head obj) - (fn [file outer-frame inner-copy] - (let [inner-label (thi/label (:main-component-id obj))] - (thc/instantiate-component file inner-label inner-copy - {:parent-label outer-frame}))))))) + (reduce (fn [situation _] (nest-once situation name this)) + situation + (range levels)))) (defn make-nested-component - "Wrap lineage `name`'s component in a NEW OUTER component (containing a copy of - it) and make the OUTER component its next-to-instantiate; advance :main to the - deeper rect while :remote stays fixed; append a `nesting-data` entry (with the - swap-stable :nested-head-parent) and bump nesting-count. ONE notion of nesting - (contain-outward). Apply repeatedly to deepen." - [name] - (tm/assign-id (->MakeNestedComponent name))) + "Wrap lineage `name`'s component in a new outer component, whose main holds + a copy of it; `levels` times (default 1), each wrapping the previous one." + ([name] (make-nested-component name 1)) + ([name levels] + (tm/assign-id (->MakeNestedComponent name levels)))) + +(defn nesting-depth + "How many times lineage `name`'s component has been nested." + [situation name] + (:nesting-count (get-component-obj situation name))) ;; --------------------------------------------------------------------------- -;; instantiate-copy — instantiate the lineage's current component, track the copy +;; instantiate-copy — a copy of the lineage's current component ;; --------------------------------------------------------------------------- (defrecord InstantiateCopy [name] @@ -777,7 +660,6 @@ (thc/instantiate-component comp-label copy-head)) objects (:objects (thf/current-page file')) copy-id (thi/id copy-head) - ;; the rect inside the copy corresponding to the current main rect copy-rect (descendant-corresponding-to objects copy-id main-rect)] (-> situation (tm/with-file file') @@ -790,57 +672,24 @@ (tm/record-application this {:component name :copy copy-id}))))) (defn instantiate-copy - "Instantiate lineage `name`'s current component; track the copy's head and the - rect corresponding to its current main rect on the lineage object (as - :copy-head/:copy-rect, and appended to :copies). The copy rect is the shape - edits-to-copy target and assertions observe." + "Instantiate lineage `name`'s current component and track the copy's head + and its image of the main rect." [name] (tm/assign-id (->InstantiateCopy name))) -;; --------------------------------------------------------------------------- -;; reset-copy-instance — reset overrides on the tracked copy instance -;; --------------------------------------------------------------------------- - -(defrecord ResetCopyInstance [name] - IComponentOperation - (op-kind [_] :user) - - tm/IOperation - (apply-to [this situation] - ;; Production reset path (generate-reset-component), validation OFF — mirrors - ;; SyncFromLibrary. We call the generator directly rather than via - ;; tho/reset-overrides because that helper validates the file, which the - ;; assembled-context frontend store does not always satisfy; and it stays a - ;; SYNC-op (`apply-to` on the live store file) rather than an event-op because - ;; the real reset event transitively reads browser globals, so it cannot run - ;; headless. - (let [the-file (tm/file situation) - copy-id (:copy-head (get-component-obj situation name)) - page (thf/current-page the-file) - container (ctn/make-container page :page) - file-id (:id the-file) - changes (-> (pcb/empty-changes) - (cll/generate-reset-component - the-file {file-id the-file} container copy-id)) - file' (thf/apply-changes the-file changes :validate? false)] - (-> situation - (tm/with-file file') - (record-changes changes) - (tm/record-application this {:component name :reset copy-id}))))) - -(defn reset-copy-instance - "Reset overrides on lineage `name`'s tracked copy instance (its :copy-head) — - discards the copy's own divergences so it reflects its main again." - [name] - (tm/assign-id (->ResetCopyInstance name))) +(defn- libraries + "The situation's files by id: the current one and the auxiliary ones." + [situation] + (let [the-file (tm/file situation)] + (assoc (tm/aux-files situation) (:id the-file) the-file))) ;; --------------------------------------------------------------------------- -;; reset — reset the overrides of any copy head +;; reset — reset the overrides of a copy head ;; ;; The "Reset overrides" action on the copy head bound to `target`, a nested -;; head included. Same production path as `reset-copy-instance` -;; (`generate-reset-component`), which is tied to a lineage's latest copy; the -;; frontend interpreter runs it as a file install for the same reason. +;; head included, through the production `generate-reset-component`. The +;; frontend interpreter runs it as a file install: the real reset event reads +;; browser globals, so it cannot run headless. ;; --------------------------------------------------------------------------- (defrecord ResetOverrides [target] @@ -854,7 +703,7 @@ page (thf/current-page the-file) changes (-> (pcb/empty-changes) (cll/generate-reset-component the-file - {(:id the-file) the-file} + (libraries situation) (ctn/make-container page :page) shape-id)) file' (thf/apply-changes the-file changes :validate? false)] @@ -869,22 +718,17 @@ [target] (tm/assign-id (->ResetOverrides target))) -(defn- libraries - "The situation's files by id, as the production code expects them: the - current file and any auxiliary (library) files." - [situation] - (let [the-file (tm/file situation)] - (assoc (tm/aux-files situation) (:id the-file) the-file))) +(defn reset-copy-instance + "Reset the overrides of lineage `name`'s latest copy." + [name] + (reset (copy-head-of name))) ;; --------------------------------------------------------------------------- ;; detach — break the link between a copy and its component ;; -;; The "Detach instance" action on the copy head bound to `target`. Drives the -;; production `generate-detach-component`, the changes the frontend -;; `detach-component` event commits. The copy's shapes lose their component -;; links and touched groups; its first-level nested copies stay copies, one -;; nesting level up, and inherit the touched groups of the shapes they -;; referenced (see `mem:common/component-sync-contract`). +;; The "Detach instance" action on the copy head bound to `target`, through +;; `generate-detach-component`. Its first-level nested copies stay copies, +;; one nesting level up (`mem:common/component-sync-contract`). ;; --------------------------------------------------------------------------- (defrecord Detach [target] @@ -908,21 +752,17 @@ (tm/record-application this {:target target :detached shape-id}))))) (defn detach - "Constructor for the detach operation: detach the copy head bound to - `target` (a role, a label or a `(situation -> id)` fn, e.g. - `copy-head-of`) from its component. On the frontend it dispatches the real - `detach-component` event." + "Constructor for the detach operation: detach the copy head `target` names + (`detach-component` on the frontend)." [target] (tm/assign-id (->Detach target))) ;; --------------------------------------------------------------------------- ;; update-main — push a copy's overrides to its main ;; -;; The "Update main component" action on the copy head bound to `target`. -;; Drives the production `generate-sync-shape-inverse`, the changes the -;; frontend `update-component` event commits (in two commits, the copy's and -;; the main's, which it tells apart by `:local-change?`; one changes here). -;; The main then differs from its other copies, so the runner syncs them. +;; The "Update main component" action on the copy head bound to `target`, +;; through `generate-sync-shape-inverse`. The frontend commits the copy's and +;; the main's changes apart, by `:local-change?`; here they go as one. ;; --------------------------------------------------------------------------- (defn- strip-local-change @@ -957,22 +797,18 @@ (defn update-main "Constructor for the update-main operation: push the overrides of the copy - head bound to `target` (a role, a label or a `(situation -> id)` fn, e.g. - `nth-copy-head-of`) to its main. On the frontend it dispatches the real - `update-component-sync` event." + head `target` names to its main (`update-component-sync` on the + frontend)." [target] (tm/assign-id (->UpdateMain target))) ;; --------------------------------------------------------------------------- ;; delete-component / restore-component ;; -;; Deleting a component deletes its main; the component stays in the file, -;; marked deleted, and its copies keep their data. Restoring it brings the -;; main back. `delete-component` drives `generate-delete-shapes` on the main -;; root, the changes the frontend `delete-component` event commits; -;; `restore-component` drives `generate-restore-component`, as the -;; frontend `restore-component` event does. The restore node asks the delete -;; node which component it deleted. +;; Deleting a component deletes its main (`generate-delete-shapes`); the +;; component stays in the file, marked deleted. Restoring it +;; (`generate-restore-component`) brings the main back. The restore node asks +;; the delete node which component it deleted. ;; --------------------------------------------------------------------------- (defrecord DeleteComponent [target] @@ -999,8 +835,7 @@ (defn delete-component "Constructor for the delete-component operation: delete the component whose - main root is bound to `target` (a role, a label or a `(situation -> id)` - fn). On the frontend it dispatches the real `delete-component` event." + main root `target` names (`delete-component` on the frontend)." [target] (tm/assign-id (->DeleteComponent target))) @@ -1013,9 +848,8 @@ :else (thi/id target))) (defn deleted-component-id - "The id of the component that the `delete-component` node `node` deleted: - the one whose main root is the node's target. Read from the file, so it - holds in both runners." + "The id of the component the `delete-component` node `node` deleted, read + from the file." [situation node] (let [root-id (target-id situation (:target node))] (or (->> (get-in (tm/file situation) [:data :components]) @@ -1051,19 +885,16 @@ (defn restore-component "Constructor for the restore-component operation: restore the component - that the `delete-component` node `deletion` deleted. On the frontend it - dispatches the real `restore-component` event." + the `delete-component` node `deletion` deleted." [deletion] (tm/assign-id (->RestoreComponent deletion))) ;; --------------------------------------------------------------------------- ;; duplicate — duplicate a shape in place ;; -;; The "Duplicate" action on the shape bound to `target`, with no offset. -;; Drives the production `generate-duplicate-changes`, the changes the -;; frontend `duplicate-shapes` event commits. The new subtree's head is read -;; from the file (the new shape whose parent existed before), so -;; `duplicate-head-of` works in both runners. +;; The "Duplicate" action on the shape bound to `target`, with no offset, +;; through `generate-duplicate-changes`. `duplicate-head-of` finds the new +;; subtree in the file. ;; --------------------------------------------------------------------------- (defn- new-subtree-head @@ -1109,9 +940,8 @@ (applied-result this the-file file'))))))) (defn duplicate - "Constructor for the duplicate operation: duplicate the shape bound to - `target` (a role, a label or a `(situation -> id)` fn) in place. On the - frontend it dispatches the real `duplicate-shapes` event." + "Constructor for the duplicate operation: duplicate the shape `target` + names in place (`duplicate-shapes` on the frontend)." [target] (tm/assign-id (->Duplicate target))) @@ -1123,13 +953,10 @@ ;; --------------------------------------------------------------------------- ;; nest-copy — move an existing copy into a main ;; -;; Nests a copy in a component by moving it there: the copy head bound to -;; `copy` is relocated, as the last child, under the shape bound to `into` -;; (e.g. another lineage's main head). Drives the production -;; `generate-relocate`, the changes the frontend `relocate-shapes` event -;; commits (dragging the copy into the main in the layers panel). Unlike -;; `make-nested-component`, an assembly step, it is a user action, so the -;; copies of the receiving main sync and the step goes through undo. +;; Moves the copy head bound to `copy` under the shape bound to `into`, as its +;; last child, through `generate-relocate`, as dragging it in the layers +;; panel does. Unlike `make-nested-component` it is a user action, so the +;; receiving main's copies sync and the step goes through undo. ;; --------------------------------------------------------------------------- (defn nest-target-index @@ -1161,79 +988,17 @@ (tm/record-application this {:copy copy :into into}))))) (defn nest-copy - "Constructor for the nest-copy operation: move the copy head bound to `copy` - under the shape bound to `into`, as its last child (both a role, a label - or a `(situation -> id)` fn). On the frontend it dispatches the real - `relocate-shapes` event." + "Constructor for the nest-copy operation: move the copy head `copy` names + under the shape `into` names, as its last child." [copy into] (tm/assign-id (->NestCopy copy into))) ;; --------------------------------------------------------------------------- -;; swap-component — replace a nested subinstance head with an instance of a -;; different component (the general "Swap component" action), in place. +;; swap-shape — swap a copy head for another component ;; -;; Targets lineage `name`'s nesting level `level` (its `nesting-data[level] -;; .nested-head`) and swaps it for lineage `target`'s component -;; (`:main-component-id`). Drives the production `generate-component-swap-in-place` -;; (validation off), the changes the `component-swap` event commits. The -;; `apply-to` below is the pure realisation; the frontend -;; interpreter instead dispatches the real `dwl/component-swap` event, so the -;; watcher auto-propagates the swap. keep-touched? defaults -;; false (the general swap discards overrides; variant-switch would pass true). -;; -;; A swap REPLACES the head in place (Penpot keeps the head's id but rewrites it to -;; reference the new component and stamps a :swap-slot touched group). The level's -;; :nested-head-parent is unchanged, so assertions re-resolve parent -> current -;; head -> rect. -;; --------------------------------------------------------------------------- - -(defrecord SwapComponent [name level target keep-touched?] - IComponentOperation - (op-kind [_] :user) - - tm/IOperation - (apply-to [this situation] - (let [the-file (tm/file situation) - page (thf/current-page the-file) - nested-head (:nested-head (lineage-nesting situation name level)) - shape (get (:objects page) nested-head) - target-id (lineage-component-id situation target) - [new-shape changes _] - (clv/generate-component-swap-in-place (pcb/empty-changes nil (:id page)) - page - (libraries situation) - (:data the-file) - shape - target-id - (boolean keep-touched?)) - file' (thf/apply-changes the-file changes :validate? false)] - (-> situation - ;; record the swapped-in head id on the level (its parent is unchanged) - (tm/with-file file') - (record-changes changes) - (update-component-obj - name - (fn [o] (assoc-in o [:nesting-data level :swapped-head] (:id new-shape)))) - (tm/record-application this {:component name :level level - :target target :new-head (:id new-shape)}))))) - -(defn swap-component - "Swap lineage `name`'s nesting level `level` for lineage `target`'s component - (the general Swap-component action). `keep-touched?` (default false) preserves - the swapped instance's overrides (true = the variant-switch flavour)." - [name level target & {:keys [keep-touched?] :or {keep-touched? false}}] - (tm/assign-id (->SwapComponent name level target keep-touched?))) - -;; --------------------------------------------------------------------------- -;; swap-shape — swap any copy head for another lineage's component -;; -;; The general Swap-component action on the copy head bound to `target` (a -;; role, a label or a `(situation -> id)` fn, e.g. a copy's nested head found -;; with `corresponding-shape-id`), replacing it with an instance of lineage -;; `to`'s component. Same production path as `swap-component` -;; (`generate-component-swap-in-place`; frontend `component-swap`), which is -;; tied to a lineage's main-side nested heads. The swap keeps the head's id, -;; so a target that named it keeps naming the new head. +;; The "Swap component" action on the copy head bound to `target`, through +;; `generate-component-swap-in-place` (`component-swap` on the frontend). The +;; new head keeps the old one's id, so a target that named it still does. ;; --------------------------------------------------------------------------- (defn swap-target-id @@ -1267,19 +1032,23 @@ (tm/record-application this {:target target :to to :keep-touched? keep-touched?}))))) (defn swap-shape - "Swap the copy head bound to `target` for the component `to` names, a - lineage name or a component label (the general Swap-component action). + "Swap the copy head `target` names for the component `to` names. `keep-touched?` (default false) keeps the head's overrides." [target to & {:keys [keep-touched?] :or {keep-touched? false}}] (tm/assign-id (->SwapShape target to keep-touched?))) +(defn swap-component + "Swap the nested head at lineage `name`'s nesting level `level` for lineage + `target`'s component, as `swap-shape` does." + [name level target & {:keys [keep-touched?] :or {keep-touched? false}}] + (swap-shape (nested-head-of name level) target :keep-touched? keep-touched?)) + ;; --------------------------------------------------------------------------- ;; move-to-cell — move a child of a grid board to another cell ;; -;; Drops the child bound to `child` into the cell at `row`, `column` of its -;; grid board `board`: the board's cells change, as the commit of a canvas -;; drop does (the modifiers end in a new `:layout-grid-cells`). Both runners -;; write it with `update-shapes` on the board (`move-to-cell-fn`). +;; Moves the child bound to `child` to the cell at `row`, `column` of its grid +;; board `board`: the board gets new `:layout-grid-cells`, as a canvas drop +;; commits. ;; --------------------------------------------------------------------------- (defn move-to-cell-fn @@ -1320,49 +1089,30 @@ (tm/assign-id (->MoveToCell board child row column))) ;; =========================================================================== -;; VARIANT operations (case M) — the variant-switch flavour of the swap sweep. +;; Variants ;; -;; A VARIANT SET is N peer components grouped in a container, distinguished by a -;; selector PROPERTY (here a single property at pos 0). Instantiation selects a -;; member by its property VALUE; a later `switch-variant` re-selects within the -;; set. Under the hood a switch is a keep-touched swap whose target is resolved -;; by property value (see `app.main.data.workspace.variants/variant-switch`), so -;; it routes through the SAME `generate-component-swap` as `swap-component` and -;; the watcher auto-propagates it across nesting levels exactly like a swap. -;; -;; OP SPLIT: the SWITCH is a user action. The frontend interpreter dispatches -;; the real `variants-switch` event; its pure `apply-to` builds the same changes -;; with the production `find-switch-target` and -;; `generate-component-swap-in-place`. The container build and the variant -;; nesting are SYNC-ops (test-helper assembly + the shared nesting helper), -;; applied via `apply-to` against the live store file; they record the -;; variant-set in vars. The switch needs no bookkeeping: the asserter -;; re-resolves heads via the swap-stable :nested-head-parent -;; (`nested-head-of`/`level-rect`), exactly as case L does for swaps. -;; -;; Member SELECTOR: `make-variant-container` assigns each member an EXPLICIT property -;; value we choose (the `value` in its [value color] specs). A member is addressed by -;; that value in `make-nested-component-with-variant` / `switch-variant`, resolved via -;; the recorded variant-set in vars. +;; A variant set is a container of member components told apart by the value +;; of one property. A switch is a keep-touched swap to the member with +;; another value. Building the set and nesting a member are assembly steps; +;; the switch is a user action. ;; =========================================================================== (def ^:private variant-property-name - "The single selector property's name (these tests use one property)." + "The name of the one property of the variant sets." "Property 1") (defn variant-set - "Read the variant-set record `set-name` from the situation's vars (written by - `make-variant-container`): {:variant-id, :container-label, :members [{:value - :component-label :component-id} ...]}." + "The variant set `set-name` that `make-variant-container` recorded: + `{:variant-id :container-label :members}`." [situation set-name] (or (tm/get-var situation [::variant-set set-name]) (throw (ex-info "variant-set: no such set (was make-variant-container applied?)" {:set set-name})))) (defn variant-member - "The member record of set `set-name` whose selector value is `value` ({:value - :component-label :component-id :root-label :rect-label :rect-id}). Throws if no - unique member matches — a structural invariant." + "The member of set `set-name` with value `value`: `{:value :component-label + :component-id :root-label :rect-label :rect-id}`. Throws unless exactly one + matches." [situation set-name value] (let [members (:members (variant-set situation set-name)) matches (filter #(= value (:value %)) members)] @@ -1374,33 +1124,19 @@ (throw (ex-info "variant-member: ambiguous value" {:set set-name :value value :count (count matches)}))))) -(defn variant-member-component-label - "The component label of set `set-name`'s member whose selector value is `value`." - [situation set-name value] - (:component-label (variant-member situation set-name value))) - (defn variant-member-component-id - "The component id of set `set-name`'s member whose selector value is `value`." + "The component id of set `set-name`'s member with value `value`." [situation set-name value] (:component-id (variant-member situation set-name value))) ;; --------------------------------------------------------------------------- -;; make-variant-container — build a variant SET synchronously +;; make-variant-container — build a variant set ;; -;; On our branch the only user-facing combine is the async `combine-as-variants` -;; (behind `penpot.createVariantFromComponents`), whose settlement + positional, -;; non-chosen property values make it a poor fit — and case M tests the SWITCH, not -;; the combine. So we assemble the container the way the variant test-helpers do -;; (`add-variant`): a container frame (:is-variant-container) whose children are the -;; member component roots, each carrying the shared :variant-id and an EXPLICIT -;; selector value we choose. This is synchronous (a sync-op, like create-component), -;; produces exactly the structure `variant-switch`/`find-variant-components` -;; consume, and lets us address members by a value of our choosing. -;; -;; `members` is a vector of [value color] — value = the selector value used by -;; `make-nested-component-with-variant` / `switch-variant`; color = the member's -;; rect fill (how the asserter tells members apart). The set is recorded in vars -;; under `name` (variant-id + per-member component labels/ids). +;; Built with test helpers, as `thv/add-variant` does: a variant container +;; frame whose children are the member roots, each a component with the set's +;; variant id and the value given to it. The app's combine is asynchronous +;; and picks the values itself. `members` is a vector of [value color], color +;; the fill of the member's rect. ;; --------------------------------------------------------------------------- (defrecord MakeVariantContainer [name members size] @@ -1409,15 +1145,8 @@ tm/IOperation (apply-to [this situation] - ;; Build the set exactly as the variant test-helpers' `add-variant` do (the - ;; proven idiom): a container frame (:is-variant-container), then each member's - ;; ROOT as a child carrying :variant-id + :variant-name, made into a component, - ;; then `update-component` stamps :variant-id + :variant-properties ON THE - ;; COMPONENT. (Routing this through add-simple-component's positional component - ;; params silently dropped :variant-id — hence the explicit two-step here.) (let [container-label (keyword (str "sync-" name "-vcontainer")) - ;; create the container frame FIRST, THEN read its id (thi/id is a lookup - ;; that only resolves once the shape exists — reading it earlier yields nil). + ;; the container's id exists once the container does base-file (-> (tm/file situation) (ths/add-sample-shape container-label :type :frame @@ -1430,8 +1159,6 @@ root-label (keyword (str "sync-" name "-v" idx "-root")) rect-label (keyword (str "sync-" name "-v" idx "-rect")) file2 (-> file - ;; member root as a child of the container, with variant id/name - ;; (mirrors add-variant's `add-sample-shape :type :frame ...`) (ths/add-sample-shape root-label (cond-> {:type :frame :parent-label container-label @@ -1442,7 +1169,7 @@ (cond-> {:parent-label root-label :fills (ths/sample-fills-color :fill-color color)} size (assoc :width (/ size 2) :height (/ size 2)))) - ;; make it a component, then stamp variant metadata ON THE COMPONENT + ;; the component gets the variant data too (thc/make-component comp-label root-label) (thc/update-component comp-label @@ -1466,24 +1193,17 @@ :count (count members)}))))) (defn make-variant-container - "Build a variant SET named `name` synchronously (test-helper assembly, like the - variant test-helpers' `add-variant`): a container holding N member components, - each with the shared variant-id and an EXPLICIT selector value. `members` is a - vector of [value color]. Members are addressed by `value` in - `make-nested-component-with-variant` / `switch-variant`; `color` distinguishes - them for the asserter. `:size` gives each member root that width and height, - and its rect half of it, as in `create-component`." + "Build a variant set `name` with one member per [value color] of + `members`. `:size` sizes the member roots as in `create-component`." [name members & {:keys [size]}] (tm/assign-id (->MakeVariantContainer name members size))) ;; --------------------------------------------------------------------------- -;; make-nested-component-with-variant — nest a chosen VARIANT, deeply +;; make-nested-component-with-variant — nest a variant member ;; -;; Same contain-outward nesting as `make-nested-component` (shares -;; `nest-in-new-outer-component`), except the inner instance is a SPECIFIC variant -;; member (selected by property `value`) rather than the lineage's own component. -;; So every nesting level introduces a variant subinstance head — the switch -;; target. Sync-op (test-helper instantiation), like `make-nested-component`. +;; As `make-nested-component`, but the copy in the new outer main is one of a +;; variant member, which becomes the lineage's original: later plain nestings +;; follow its image. ;; --------------------------------------------------------------------------- (defrecord MakeNestedComponentWithVariant [name set-name value] @@ -1503,35 +1223,22 @@ (fn [file outer-frame inner-copy] (thc/instantiate-component file (:component-label member) inner-copy {:parent-label outer-frame}))) - ;; nesting a variant makes the MEMBER the new deepest origin: re-point the - ;; lineage's fixed origin so subsequent plain make-nested-component descends to the - ;; variant's image (its nested-head) at every level. (update-component-obj name #(assoc % :remote-head root-id :remote-rect rect-id)))))) (defn make-nested-component-with-variant - "Nest (contain-outward, like `make-nested-component`) a SPECIFIC variant member of set - `set-name` — the member whose selector value is `value` — under lineage `name`, - advancing `name`'s nesting. Every level so nested gets a variant subinstance - head that `switch-variant` can later re-select. Apply repeatedly to deepen." + "Wrap a copy of the member of set `set-name` with value `value` in a new + outer component of lineage `name`." [name set-name value] (tm/assign-id (->MakeNestedComponentWithVariant name set-name value))) ;; --------------------------------------------------------------------------- ;; switch-variant — switch a variant copy head to a sibling member ;; -;; The variant-switch action: switch the variant copy head bound to `target` to the -;; sibling member whose selector property (pos 0) has `value`. The production -;; switch DISCOVERS the sibling by value within the variant container and swaps -;; with keep-touched? true, so sync propagates it across nesting levels exactly -;; like case L's swap. On the frontend it is the `variants-switch` event. The +;; Switches the variant copy head bound to `target` to the member whose +;; property has `value`, through `find-switch-target` and a keep-touched +;; `generate-component-swap-in-place` (`variants-switch` on the frontend). The ;; event's follow-ups (token propagation, WASM text resize, layout update) are -;; frontend code and the pure `apply-to` does not run them. A switch REPLACES the head in place; the head's -;; :parent is unchanged, so assertions re-resolve parent -> current head -> rect. -;; -;; `target` is the head to switch, resolved by the standard `target-shape-id` (role -;; | label | (situation -> id) fn, e.g. `nested-head-of` for the stored nested head -;; at a level — exactly the head `swap-component` targets). So the op knows NOTHING -;; about nesting. +;; frontend code, left out here. ;; --------------------------------------------------------------------------- (defrecord SwitchVariant [target value] @@ -1574,90 +1281,64 @@ (tm/record-application this {:target-component (:id component)}))))))) (defn switch-variant - "Switch the variant copy head bound to `target` to the sibling member whose - selector property (pos 0) has value `value`, via the real `variants-switch` - machinery (which discovers the sibling within the container). Propagates across - nesting exactly like case L's swap. `target` is resolved like any operation target - (role | label | (situation -> id) fn, e.g. `nested-head-of`), so the op is - structure-agnostic." + "Switch the variant copy head `target` names to the member whose property + has value `value`." [target value] (tm/assign-id (->SwitchVariant target value))) -;; nested-head-of — a (situation -> id) target fn for the nested head at a level, -;; supplied to `switch-variant` so the operation needs no nesting knowledge. -(defn nested-head-of - "Target fn: the subinstance head introduced at lineage `name`'s nesting level `i` - — the `:nested-head` stored in nesting-data for that level (exactly the head - `swap-component` targets). This is the variant instance to switch. For - `switch-variant`'s `target`." - [name i] - (fn [s] (:nested-head (lineage-nesting s name i)))) ;; --------------------------------------------------------------------------- ;; sync-from-library — pull a linked library's changes into the consuming file ;; -;; LOCALITY axis (case H): the main lives in a SEPARATE library file and the copy -;; in the consuming (current) file. Propagation here crosses a FILE boundary and -;; is NOT the in-file component watcher — on the real frontend it is the library -;; UPDATE action (the user accepts "library updated"), realised as -;; `sync-file file-id library-id`. This node models that action. -;; -;; The situation carries the consuming file as its primary `:file` and the library -;; as an AUXILIARY file (see `tm/with-aux-files`). The pure `apply-to` realisation -;; below builds the libraries map from BOTH and runs `generate-sync-file-changes` -;; for the whole library (asset-id nil), mirroring `test-sync-when-changing- -;; lower-remote`. The frontend interpreter instead dispatches the real -;; `sync-file` event (see its `op->events`). +;; The library update action, accepted by the user: the copies in the current +;; file sync from the situation's auxiliary library file, through +;; `generate-sync-file-changes` (`sync-file` on the frontend). The component +;; watcher never crosses files. ;; --------------------------------------------------------------------------- +(defn library-id + "The id of the library file of a cross-file situation, its only auxiliary + file." + [situation] + (-> situation tm/aux-files keys first)) + (defrecord SyncFromLibrary [] IComponentOperation (op-kind [_] :user) tm/IOperation (apply-to [this situation] - (let [the-file (tm/file situation) - file-id (:id the-file) - aux (tm/aux-files situation) - library-id (first (keys aux)) - libraries (assoc aux file-id the-file) - changes (-> (pcb/empty-changes) - (cll/generate-sync-file-changes - nil - :components - file-id - nil ; whole library (no single asset-id) - library-id - libraries - file-id)) - file' (thf/apply-changes the-file changes :validate? false)] + (let [the-file (tm/file situation) + file-id (:id the-file) + lib-id (library-id situation) + changes (-> (pcb/empty-changes) + (cll/generate-sync-file-changes nil + :components + file-id + nil ; the whole library + lib-id + (libraries situation) + file-id)) + file' (thf/apply-changes the-file changes :validate? false)] (-> situation (tm/with-file file') (record-changes changes) - (tm/record-application this {:library-id library-id}))))) + (tm/record-application this {:library-id lib-id}))))) (defn sync-from-library - "Constructor for the cross-file library-sync node (case H). Takes no parameters; - the situation supplies the consuming file (primary) and the library (auxiliary)." + "Constructor for the library update of the current file from the + situation's library." [] (tm/assign-id (->SyncFromLibrary))) ;; --------------------------------------------------------------------------- -;; undo — reverse the immediately preceding operation(s) +;; undo — revert the latest operations ;; -;; Undo is "just another operation node": the APP owns reversal; this node does -;; not snapshot-and-compare. It is an EVENT-op: the frontend interpreter -;; dispatches the real `dwu/undo` event, which pops the workspace undo stack -;; (maintained automatically by the prior operations' commits) and applies the -;; inverse changes. "Test undo everywhere" = append this node after any case; the -;; post-undo assertion is an ordinary condition about the resulting state. -;; -;; The pure runner (`app.common.test-helpers.composable.comp.runner`) realises -;; it from the changes that user operations record (`record-changes`). A bare -;; `apply-to` has no undo stack to read, so it throws loudly rather than -;; pretending. +;; Runs on a runner's undo stack: the workspace's (`dwu/undo`) in the frontend +;; interpreter, the recorded changes in the pure runner. `apply-to` alone has +;; no stack and throws. ;; --------------------------------------------------------------------------- (defrecord Undo [times] @@ -1672,9 +1353,8 @@ {:type ::undo-is-event-op})))) (defn undo - "Constructor for the undo node (case I): undo the latest `times` (default 1) - user operations, each with the syncs it caused. On the frontend it - dispatches the real undo `times` times." + "Constructor for the undo node: undo the latest `times` (default 1) user + operations, each with the syncs it caused." ([] (undo 1)) ([times] (tm/assign-id (->Undo times)))) @@ -1682,9 +1362,7 @@ ;; --------------------------------------------------------------------------- ;; redo — apply again the latest undone operation(s) ;; -;; The twin of `undo`. The frontend interpreter dispatches the real `dwu/redo` -;; event; the pure runner applies the redo changes of the latest undone group. -;; A new user operation empties the redo stack, as in the frontend. +;; Runs on a runner's redo stack, which a new user operation empties. ;; --------------------------------------------------------------------------- (defrecord Redo [] @@ -1699,8 +1377,7 @@ {:type ::redo-is-event-op})))) (defn redo - "Constructor for the redo node. Takes no parameters; on the frontend it - dispatches the real redo, applying again the latest undone operation(s)." + "Constructor for the redo node: apply again the latest undone operation." [] (tm/assign-id (->Redo))) @@ -1724,27 +1401,30 @@ {:type ::undo-before-sync-is-frontend-only})))) (defn undo-before-sync - "Constructor for the undo-before-sync node: change `property` of the shape - bound to `target` to `value` and undo it while its sync is still pending. - The frontend interpreter dispatches the edit and the real undo together." + "Constructor for the undo-before-sync node: set `property` of the shape + `target` names to `value` and undo it while its sync is still pending." [target property value] (tm/assign-id (->UndoBeforeSync target property value))) ;; --------------------------------------------------------------------------- -;; add-child — add a new shape into a (main) component, structurally +;; add-child — add a shape ;; -;; This is STRUCTURAL modification (changes the tree shape), as opposed to -;; change-attr (attribute modification). It builds the new shape under the -;; target parent with `prepare-add-shape`, the same changes the frontend -;; `add-shape` event commits, so one undo removes it whole. Propagation then -;; materializes a corresponding child in copies. -;; -;; `parent` is the binding name of the shape to add the new child under (e.g. -;; :main-root). `new-label` is the label assigned to the created shape, so a -;; condition can find the corresponding copy child by what was recorded. +;; Adds a shape labelled `new-label` under the shape labelled `parent`, +;; through `prepare-add-shape`, as the frontend `add-shape` event does. ;; --------------------------------------------------------------------------- +(defn child-shape + "The shape `add-child` adds under the shape `parent`: a sample shape + labelled `new-label` with `shape-params`. Public so the frontend + interpreter adds the same shape." + [parent new-label shape-params] + (-> (ths/sample-shape new-label (or shape-params {})) + (assoc :parent-id (:id parent) + :frame-id (if (cfh/frame-shape? parent) + (:id parent) + (:frame-id parent))))) + (defrecord AddChild [parent new-label shape-params] IComponentOperation (op-kind [_] :user) @@ -1752,17 +1432,11 @@ tm/IOperation (apply-to [this situation] (let [the-file (tm/file situation) - ;; strict-presence on the parent (it must exist before we add under it) parent-id (tm/resolve-shape-id situation parent) page (thf/current-page the-file) objects (:objects page) - parent-obj (get objects parent-id) ;; registers `new-label` - shape (-> (ths/sample-shape new-label (or shape-params {})) - (assoc :parent-id parent-id - :frame-id (if (cfh/frame-shape? parent-obj) - parent-id - (:frame-id parent-obj)))) + shape (child-shape (get objects parent-id) new-label shape-params) [_ changes] (cfsh/prepare-add-shape (pcb/empty-changes nil (:id page)) shape objects) @@ -1773,23 +1447,17 @@ (tm/record-application this {:parent parent :new-label new-label}))))) (defn add-child - "Constructor for the structural add-child node: create a new shape (labeled - `new-label`) and relocate it under the shape bound to `parent`. Stamps a node - identity so the test can interrogate it." + "Constructor for the add-child node: add a shape labelled `new-label` under + the shape labelled `parent`." [parent new-label & {:as shape-params}] (tm/assign-id (->AddChild parent new-label shape-params))) ;; --------------------------------------------------------------------------- -;; remove-child — delete a shape from a (main) component, structurally +;; remove-child — delete a shape ;; -;; Subtractive structural modification (twin of add-child). Mirrors the -;; established comp-sync-test "delete shape" pattern: `generate-delete-shapes` -;; on the named shape in the main. Propagation then removes the corresponding -;; child from clean copies. (Domain note from comp-sync-test: deleting from a -;; COPY would only hide; here we delete from the MAIN and propagate the removal.) -;; -;; `target` is the binding name (label) of the shape to remove from the main. +;; Deletes the shape labelled `target`, in a main or a copy, through +;; `generate-delete-shapes`. ;; --------------------------------------------------------------------------- (defrecord RemoveChild [target] @@ -1799,7 +1467,6 @@ tm/IOperation (apply-to [this situation] (let [the-file (tm/file situation) - ;; strict-presence: the target must exist before removal shape-id (tm/resolve-shape-id situation target) page (thf/current-page the-file) [_all-parents changes] @@ -1816,23 +1483,17 @@ (tm/record-application this {:target target}))))) (defn remove-child - "Constructor for the structural remove-child node: delete the shape bound to - `target` from the main. Stamps a node identity." + "Constructor for the remove-child node: delete the shape labelled + `target`." [target] (tm/assign-id (->RemoveChild target))) ;; --------------------------------------------------------------------------- -;; move-child — reorder an existing shape within a (main) component +;; move-child — reorder a shape ;; -;; Structural modification where nothing is created or destroyed; only ORDER -;; changes, and that order should propagate to clean copies while :shape-ref -;; identity stays decoupled from position. Mirrors the established comp-sync-test -;; "move shape" pattern: `generate-relocate` of an EXISTING child to a new index -;; under the same parent. -;; -;; `target` is the binding name (label) of the existing main child to move; -;; `to-index` is its destination index under `parent`. +;; Moves the shape labelled `target` to index `to-index` under the shape +;; labelled `parent`, through `generate-relocate`. ;; --------------------------------------------------------------------------- (defrecord MoveChild [target parent to-index] @@ -1859,22 +1520,18 @@ (tm/record-application this {:target target :parent parent :to-index to-index}))))) (defn move-child - "Constructor for the structural move-child node: relocate the existing shape - bound to `target` to `to-index` under the shape bound to `parent`. Stamps a - node identity." + "Constructor for the move-child node: move the shape labelled `target` to + `to-index` under the shape labelled `parent`." [target parent to-index] (tm/assign-id (->MoveChild target parent to-index))) - (defprotocol IStructuralCheck - "Inspection capability of a structural node: retrieve the shapes involved in its - own effect, so the test can state ref-integrity / placement assertions itself." + "The shapes a structural node's effect involves, for the test to assert on." (added-shape [node situation] - "The shape this node added to the main (live, from the current file).") + "The live shape this node added.") (materialized-instance-child [node situation container-shape] - "The child of `container-shape` that is the materialized instance of this - node's added shape (i.e. whose :shape-ref points at it), or nil. Retrieval - only — the test asserts the relationship.")) + "The child of `container-shape` whose :shape-ref is this node's added + shape, or nil.")) (extend-type AddChild IStructuralCheck diff --git a/common/src/app/common/test_helpers/composable/comp/runner.cljc b/common/src/app/common/test_helpers/composable/comp/runner.cljc index 5477097d9e..afe767aad9 100644 --- a/common/src/app/common/test_helpers/composable/comp/runner.cljc +++ b/common/src/app/common/test_helpers/composable/comp/runner.cljc @@ -45,7 +45,7 @@ ;; A guard against a sync cascade that never settles. (def ^:private max-sync-passes 100) -(defn- changed-components +(defn changed-components "Ids of the components whose main `changes` modified, judged against `old-data`, the file data before `changes` applied." [old-data changes] @@ -68,33 +68,21 @@ (thf/validate-file! file (libraries situation file)) situation)) -(defn- component-sync-changes - "The changes that sync the copies of `component-id` in `file`, as the - frontend `sync-file` event builds them for a local component." - [situation file component-id] - (let [file-id (:id file)] - (cll/generate-sync-file-changes (pcb/empty-changes) - nil - :components - file-id - component-id - file-id - (libraries situation file) - file-id))) - -(defn- sync-file - "Sync `situation`'s file, starting from the components that `changes` - modified (judged against `old-data`), until no component is left to sync, - and validate the result. Returns `[situation syncs]`, with `syncs` the - applied sync changes in order." - [situation old-data changes] - (loop [file (tm/file situation) - pending (vec (changed-components old-data changes)) +(defn sync-cascade + "Sync the copies of `component-ids` in `file`, then those of the components + each sync changed, until none is left, as the frontend `sync-file` event + builds the changes for a local component; the frontend watcher runs one + pass per sync commit. `libraries` are the other files by id. Returns + `{:file :syncs :passes}`, with `syncs` the sync changes that changed + something, in order." + [file libraries component-ids] + (loop [file file + pending (vec component-ids) syncs [] passes 0] (cond (empty? pending) - [(validate-settled! (tm/with-file situation file)) syncs] + {:file file :syncs syncs :passes passes} (>= passes max-sync-passes) (throw (ex-info "Component sync did not settle" @@ -103,16 +91,33 @@ :passes passes})) :else - (let [component-id (first pending) - sync (component-sync-changes situation file component-id) - file' (thf/apply-changes file sync :validate? false) - more (->> (changed-components (:data file) sync) - (remove (set pending)))] + (let [file-id (:id file) + sync (cll/generate-sync-file-changes (pcb/empty-changes) + nil + :components + file-id + (first pending) + file-id + (assoc libraries file-id file) + file-id) + file' (thf/apply-changes file sync :validate? false) + more (->> (changed-components (:data file) sync) + (remove (set pending)))] (recur file' (into (subvec pending 1) more) (cond-> syncs (seq (:redo-changes sync)) (conj sync)) (inc passes)))))) +(defn- sync-file + "Sync `situation`'s file, starting from the components that `changes` + modified (judged against `old-data`), and validate the result. Returns + `[situation syncs]`, with `syncs` the applied sync changes in order." + [situation old-data changes] + (let [{:keys [file syncs]} (sync-cascade (tm/file situation) + (tm/aux-files situation) + (changed-components old-data changes))] + [(validate-settled! (tm/with-file situation file)) syncs])) + (defn- push-undo-group "Add `group`, the changes of one user operation and its syncs in order, to the undo stack and empty the redo stack. Changes with nothing to undo are diff --git a/common/src/app/common/test_helpers/composable/comp/setups.cljc b/common/src/app/common/test_helpers/composable/comp/setups.cljc index 06165c3231..94435f5295 100644 --- a/common/src/app/common/test_helpers/composable/comp/setups.cljc +++ b/common/src/app/common/test_helpers/composable/comp/setups.cljc @@ -5,22 +5,11 @@ ;; Copyright (c) KALEIDOS SUBSIDIARY SL (ns app.common.test-helpers.composable.comp.setups - "Component-specific setups for the test model: named functions that build an - in-memory file value for a particular component configuration. They are the - subject-specific counterpart to the generic engine; a 'simple component with - a copy' is an entirely component-shaped configuration, so it lives behind the - `comp` boundary. See `mem:frontend/composable-component-tests`. - - Setups are kept as plain functions (not data): structure resists - declarativization and forcing it here has the worst cost/benefit. Each returns - a *situation* (file + ROLE bindings — meaningful named objects of the - configuration, e.g. :main-instance, :copy-instance), which the test retrieves - via the accessors below and asserts on directly. - - For these one-child-per-instance configurations the meaningful objects are the - child shapes that participate in propagation, so :main-instance is the main's - child and :copy-instance is the copy's child (this makes a test read like - `(has-attr? change-attr (copy-instance situation))`)." + "Setups of the composable component cases: functions that build a file + and return a situation with its roles (see + `mem:frontend/composable-component-tests`). In the one-child setups, + :main-instance and :copy-instance are the children of the main and the + copy." (:require [app.common.data :as d] [app.common.files.changes-builder :as pcb] @@ -30,8 +19,10 @@ [app.common.test-helpers.compositions :as tho] [app.common.test-helpers.files :as thf] [app.common.test-helpers.ids-map :as thi] - [app.common.test-helpers.shapes :as ths] - [app.common.types.shape.layout :as ctl])) + [app.common.test-helpers.shapes :as ths])) + +;; The fill the labeled setups give the main child. +(def labeled-fill "#abcdef") (defn simple-component-with-copy "A situation with a simple component (root + one child) and one clean copy. @@ -49,21 +40,19 @@ (defn empty-situation - "A situation with an empty file and NO roles — the starting point for scenarios - that build their own configuration via operations (e.g. `create-component`, - `make-nested-component`, `instantiate-copy`). Use as the `:setup` when the first - operation creates the component." + "A situation with an empty file and no roles, for cases that build their + configuration with operations (`create-component` and the like)." [] (tm/make-situation (thf/sample-file :file1))) (defn simple-component-with-labeled-copy - "Like `simple-component-with-copy`, but the main child starts with a known fill - (so 'value stayed' is distinguishable from coincidence). Same labels and roles." + "Like `simple-component-with-copy`, with the main child filled + `labeled-fill`. Same labels and roles." [] (let [file (-> (thf/sample-file :file1) (tho/add-simple-component-with-copy :component1 :main-root :main-child :copy-root - :main-child-params {:fills (ths/sample-fills-color :fill-color "#abcdef")} + :main-child-params {:fills (ths/sample-fills-color :fill-color labeled-fill)} :copy-root-params {:children-labels [:copy-child]}))] (tm/make-situation file {:main-instance :main-child :copy-instance :copy-child @@ -81,7 +70,7 @@ (let [file (-> (thf/sample-file :file1 :page-label :page1) (tho/add-simple-component-with-copy :component1 :main-root :main-child :copy-root - :main-child-params {:fills (ths/sample-fills-color :fill-color "#abcdef")} + :main-child-params {:fills (ths/sample-fills-color :fill-color labeled-fill)} :copy-root-params {:children-labels [:copy-child]}) (thf/add-sample-page :page2) (thc/instantiate-component :component1 :copy2-root @@ -117,21 +106,15 @@ :main-root :main-root :copy-root :copy-root}))) -(defn- place-in-columns - "The grid board `board` with a row and three columns, holding the shapes of - `labels` in its first columns, in order." - [board labels] - (let [board (-> board - (ctl/add-grid-row {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1})) - cells (reduce (fn [cells [column label]] - (let [[id _] (d/seek #(= column (:column (val %))) cells)] - (assoc-in cells [id :shapes] [(thi/id label)]))) - (:layout-grid-cells board) - (map vector (iterate inc 1) labels))] - (assoc board :layout-grid-cells cells))) +(defn- label-copy-children! + "Register each label of `labels` (main child label -> copy child label) on + the child of the copy `copy-label` that references that main child." + [file copy-label labels] + (let [objects (:objects (thf/current-page file))] + (doseq [[main-label copy-child-label] labels] + (thi/set-id! copy-child-label + (d/seek #(= (thi/id main-label) (get-in objects [% :shape-ref])) + (get-in objects [(thi/id copy-label) :shapes])))))) (defn grid-component-with-copy "A component whose main is a grid board (one row, three columns, 300x100) @@ -141,39 +124,22 @@ :grid-copy :copy-child1 :copy-child2 (copy side), :item, :other. Roles: :main-root, :copy-root, :main-child -> :child1, :copy-child -> :copy-child1." [] - (let [file (-> (thf/sample-file :file1) - (tho/add-simple-component :item :item-root :item-rect - :root-params {:width 100 :height 100} - :child-params {:width 50 :height 50}) - (tho/add-simple-component :other :other-root :other-rect - :root-params {:width 100 :height 100} - :child-params {:width 50 :height 50 - :fills (ths/sample-fills-color - :fill-color "#ff0000")}) - (ths/add-sample-shape :grid-root - :type :frame - :width 300 - :height 100 - :layout :grid - :layout-grid-dir :row - :layout-grid-rows [] - :layout-grid-columns [] - :layout-grid-cells {}) - (thc/instantiate-component :item :child1 :parent-label :grid-root) - (thc/instantiate-component :item :child2 :parent-label :grid-root)) - board (place-in-columns (ths/get-shape file :grid-root) [:child1 :child2]) - file (-> file - (ths/update-shape :grid-root :layout-grid-rows (:layout-grid-rows board)) - (ths/update-shape :grid-root :layout-grid-columns (:layout-grid-columns board)) - (ths/update-shape :grid-root :layout-grid-cells (:layout-grid-cells board)) - (thc/make-component :grid :grid-root) - (thc/instantiate-component :grid :grid-copy)) - objects (:objects (thf/current-page file))] - ;; the copy's children are the copies of the main's, by :shape-ref - (doseq [[main-label copy-label] [[:child1 :copy-child1] [:child2 :copy-child2]]] - (thi/set-id! copy-label - (->> (get-in objects [(thi/id :grid-copy) :shapes]) - (d/seek #(= (thi/id main-label) (get-in objects [% :shape-ref])))))) + (let [file (-> (thf/sample-file :file1) + (tho/add-simple-component :item :item-root :item-rect + :root-params {:width 100 :height 100} + :child-params {:width 50 :height 50}) + (tho/add-simple-component :other :other-root :other-rect + :root-params {:width 100 :height 100} + :child-params {:width 50 :height 50 + :fills (ths/sample-fills-color + :fill-color "#ff0000")}) + (tho/add-grid-frame :grid-root :width 300 :height 100) + (thc/instantiate-component :item :child1 :parent-label :grid-root) + (thc/instantiate-component :item :child2 :parent-label :grid-root) + (tho/place-in-grid-columns :grid-root 3 {1 :child1 2 :child2}) + (thc/make-component :grid :grid-root) + (thc/instantiate-component :grid :grid-copy))] + (label-copy-children! file :grid-copy {:child1 :copy-child1 :child2 :copy-child2}) (tm/make-situation file {:main-root :grid-root :copy-root :grid-copy :main-child :child1 @@ -187,35 +153,21 @@ (copy side, matched by :shape-ref). Roles: :main-root, :copy-root." ([] (component-with-sibling-instances :none)) ([layout] - (let [grid? (= :grid layout) - subs [:sub1 :sub2 :sub3] - file (-> (thf/sample-file :file1) - (tho/add-simple-component :icon :icon-root :icon-rect - :root-params {:width 24 :height 24} - :child-params {:width 24 :height 24}) - (ths/add-sample-shape :row-root - (cond-> {:type :frame :width 300 :height 100} - grid? (assoc :layout :grid - :layout-grid-dir :row - :layout-grid-rows [] - :layout-grid-columns [] - :layout-grid-cells {})))) - file (reduce #(thc/instantiate-component %1 :icon %2 :parent-label :row-root) file subs) - file (cond-> file - grid? - (as-> f (let [board (place-in-columns (ths/get-shape f :row-root) subs)] - (-> f - (ths/update-shape :row-root :layout-grid-rows (:layout-grid-rows board)) - (ths/update-shape :row-root :layout-grid-columns (:layout-grid-columns board)) - (ths/update-shape :row-root :layout-grid-cells (:layout-grid-cells board)))))) - file (-> file - (thc/make-component :row :row-root) - (thc/instantiate-component :row :row-copy)) - objects (:objects (thf/current-page file))] - (doseq [[main-label copy-label] (map vector subs [:copy-sub1 :copy-sub2 :copy-sub3])] - (thi/set-id! copy-label - (->> (get-in objects [(thi/id :row-copy) :shapes]) - (d/seek #(= (thi/id main-label) (get-in objects [% :shape-ref])))))) + (let [grid? (= :grid layout) + subs [:sub1 :sub2 :sub3] + file (as-> (thf/sample-file :file1) $ + (tho/add-simple-component $ :icon :icon-root :icon-rect + :root-params {:width 24 :height 24} + :child-params {:width 24 :height 24}) + (if grid? + (tho/add-grid-frame $ :row-root :width 300 :height 100) + (tho/add-frame $ :row-root :width 300 :height 100)) + (reduce #(thc/instantiate-component %1 :icon %2 :parent-label :row-root) $ subs) + (cond-> $ + grid? (tho/place-in-grid-columns :row-root 3 (zipmap [1 2 3] subs))) + (thc/make-component $ :row :row-root) + (thc/instantiate-component $ :row :row-copy))] + (label-copy-children! file :row-copy (zipmap subs [:copy-sub1 :copy-sub2 :copy-sub3])) (tm/make-situation file {:main-root :row-root :copy-root :row-copy})))) @@ -252,10 +204,9 @@ (defn component-with-many-children - "A situation with a component whose main has three children and one clean copy. - Shape labels: :main-root, :main-child1/2/3, :copy-root, :copy-child1/2/3. - Roles: :main-root, :copy-root, and :copy-child-1/2/3 -> the copy's children - (so a test can assert their post-operation order in the copy root)." + "A component whose main has three children, and a copy. Labels: :main-root + :main-child1/2/3 :copy-root :copy-child1/2/3. Roles: :main-root, + :copy-root and :copy-child-1/2/3 -> the copy's children." [] (let [file (-> (thf/sample-file :file1) (tho/add-component-with-many-children-and-copy @@ -271,30 +222,17 @@ :copy-child-3 :copy-child3}))) (defn copy-child - "The copy child shape for 1-based index `n` (role :copy-child-n), live. Lets a - test retrieve specific copy children to assert their order/identity." + "The copy child shape for 1-based index `n` (role :copy-child-n), live." [situation n] (tm/role-shape situation (keyword (str "copy-child-" n)))) (defn nested-component-with-copy - "A situation with a NESTED component configuration (depth axis): component2's - main contains a nested instance of component1 (`:main2-nested-head`); a clean - copy of component2 exists, so the copy contains a copy of that nested instance - whose child (`:copy2-child`) reaches the main through a :shape-ref CHAIN. - - This is the depth-1 analogue of the simple-with-copy setup: editing - `:main2-nested-head` (the nested instance inside component2's main) and - propagating component2 must reach `:copy2-child` — the same attribute- - propagation property as the flat case, one level deeper. (Editing the - INNERMOST :main1-child and propagating only :component1 would instead be a - CHAINED propagation across two component levels — a different property; not - this setup.) - - Shape labels from the helper: :main1-root/:main1-child, :main2-root, - :main2-nested-head, :copy2-root, and :copy2-child (the deep copy child, labeled - via the helper's children-labels). Roles: :main-instance -> :main2-nested-head, - :copy-instance -> :copy2-child, plus :main2-root / :copy-root for structure." + "Component2's main holds a copy of component1 (`:main2-nested-head`), and a + copy of component2 holds a copy of it. Labels: :main1-root :main1-child + :main2-root :main2-nested-head :copy2-root :copy2-child. Roles: + :main-instance -> :main2-nested-head, :copy-instance -> :copy2-child, + :main2-root and :copy-root." [] (let [file (-> (thf/sample-file :file1) (tho/add-nested-component-with-copy @@ -309,10 +247,8 @@ (defn- change-main-child-fill - "Apply `fill-color` to the library's :main-child via the production change path - (mirrors how a real edit to the main would have changed the library), returning - the updated library file value. Used to make the library main DIVERGE from the - already-instantiated copy, so a subsequent cross-file sync has something to pull." + "`library` with its :main-child filled `fill-color`, through the production + change path." [library fill-color] (let [page (thf/current-page library) main-id (thi/id :main-child) @@ -325,41 +261,21 @@ (thf/apply-changes library changes))) (defn cross-file-component-with-copy - "LOCALITY axis (case H): a component whose main lives in a SEPARATE, shared - LIBRARY file, and a clean copy that lives in a CONSUMING file. The library main - has since DIVERGED from the copy (its :main-child now carries `new-fill`, while - the copy still carries the original `#abcdef`), modelling 'the library was - changed elsewhere'. Propagating that change to the copy is therefore a CROSS- - FILE sync (the library-update flow), not the in-file watcher. - - The returned situation's PRIMARY file is the CONSUMING file (the current file, - where the copy lives and which the copy roles resolve against); the library - travels as an AUXILIARY file (see `tm/with-aux-files`) so an interpreter can - install it alongside (e.g. into the frontend store's `:files`) and run the - cross-file sync. Roles: :copy-instance -> the copy child, :copy-root -> the copy - root (both in the consuming file). `new-fill` should match the value the test - uses for its expected-value descriptor. - - Labels: in the LIBRARY — :component1, :main-root, :main-child; in the CONSUMING - file — :copy-root, :copy-child." + "A component in a shared library file and a copy of it in the current + file; the library main then changes its child's fill to `new-fill`, so the + copy is behind it. The library travels as an auxiliary file. Labels: in + the library :component1 :main-root :main-child, in the file :copy-root + :copy-child. Roles: :copy-instance -> :copy-child, :copy-root." [new-fill] (let [library (-> (thf/sample-file :library :is-shared true) (tho/add-simple-component :component1 :main-root :main-child - :child-params {:fills (ths/sample-fills-color :fill-color "#abcdef")})) - ;; instantiate the copy in the consuming file FIRST (copy gets the old fill) + :child-params {:fills (ths/sample-fills-color :fill-color labeled-fill)})) file (-> (thf/sample-file :file) (thc/instantiate-component :component1 :copy-root :library library :children-labels [:copy-child])) - ;; THEN diverge the library main (copy is now stale) library' (change-main-child-fill library new-fill)] (-> (tm/make-situation file {:copy-instance :copy-child :copy-root :copy-root}) (tm/with-aux-files {(:id library') library'})))) - -(defn library-id - "The id of the library file in a cross-file situation (the single auxiliary - file). Used by the cross-file sync operation." - [situation] - (-> situation tm/aux-files keys first)) diff --git a/common/src/app/common/test_helpers/composable/core.cljc b/common/src/app/common/test_helpers/composable/core.cljc index 05216745cb..c66cb81198 100644 --- a/common/src/app/common/test_helpers/composable/core.cljc +++ b/common/src/app/common/test_helpers/composable/core.cljc @@ -5,29 +5,15 @@ ;; Copyright (c) KALEIDOS SUBSIDIARY SL (ns app.common.test-helpers.composable.core - "The domain-agnostic ENGINE of the composable test model (see - `mem:frontend/composable-component-tests`): + "The domain-agnostic engine of the composable test model (see + `mem:frontend/composable-component-tests`): the situation (file, roles, + vars and the log of applied operations), node identity, strict-presence + lookup, the `IOperation` and `IEnumerable` protocols, the operators + `in-sequence`, `one-of`, `optional`, `skip` and `test-that`, and the plain + runners `run-variant` / `run-all`. Component operations live behind the + `comp` boundary (`app.common.test-helpers.composable.comp.*`). - - a `situation` carrying the in-memory file value, named ROLE bindings, - a `:vars` map, and an ordered record of applied operations, - - node identity (`assign-id`) + the applied-log (`record-application`, - `applied?`, `describe-applied`), - - strict-presence lookup that throws a diagnostic error on a missing name, - - the `IOperation` protocol (single method `apply-to`) and the - `IEnumerable` protocol behind variant enumeration, - - the composition operators `in-sequence`, `one-of`, `optional`, `skip`, - and the inline-assertion operation `test-that`, - - the enumerating pure runners `run-variant` / `run-all` (the frontend - interpreter in `frontend-tests.composable-tests.interpreter` is the - event-dispatching counterpart and the test-facing entry point). - - No Penpot domain terms live here; the component-specific operations sit - behind the `comp` boundary (`app.common.test-helpers.composable.comp.*`). - - Shape references use the existing label->uuid system (`app.common.test-helpers.ids-map`) - rather than a parallel binding map: a binding name in an operation IS a - shape label, resolved through `thi/id`. The situation adds the applied-log and - the strict-presence discipline on top of that substrate." + A shape name in an operation is a test label (`app.common.test-helpers.ids-map`)." (:refer-clojure :exclude [apply-to]) (:require [app.common.test-helpers.files :as thf] @@ -39,38 +25,19 @@ [clojure.test :as t])) ;; --------------------------------------------------------------------------- -;; Situation -;; -;; A situation wraps the in-memory Penpot file value together with the record of -;; what has been applied to it. The environment of *shape* bindings is the -;; global label->uuid map (reset per variant by the runners), so the situation -;; does not duplicate it; it only adds: -;; :file - the current in-memory file value -;; :applied-log - vector of application records, in application order +;; Situation: the in-memory file value with its roles, vars and the log of +;; what was applied to it. Shape labels live in the global label map, which +;; the runners reset per variant. ;; --------------------------------------------------------------------------- -;; resolve-shape is defined below (strict-presence section) but referenced by -;; role-shape above it; declare it so the forward reference resolves at load. -(declare resolve-shape) (declare resolve-shape-id) (defn make-situation - "Create a situation from an initial in-memory file value, optionally with role - bindings. Roles are meaningful named objects of the configuration the setup - built (e.g. :main-instance, :copy-instance), passed as shape *labels*. The - labels are resolved to ids IMMEDIATELY (at construction, while the labels are - freshly valid) and the situation stores the resolved ids. This is essential: - the global label->id map is time-varying and shared, so resolving a role label - later (e.g. in another enumerated variant's run) would be unsound; capturing - the id at setup time makes each situation resolve its roles against the file it - was built with, independent of the global map's later state. - - The situation also carries: - :applied - ordered vector of operation ids, in application order - (so the full sequence is always recoverable from the situation) - :node-data - map of operation-id -> the record that operation - wrote about its own application (keyed by NODE IDENTITY, not by - a node-kind tag), so each node retrieves its own record." + "A situation for `file`, with `roles` (role key -> shape label) resolved to + ids at once: the label map changes from variant to variant, so a role keeps + the id of the file it was built with. `:applied` holds the ids of the + applied operations in order, `:node-data` what each recorded about its + application." ([file] (make-situation file {})) ([file roles] {:file file @@ -85,20 +52,15 @@ (:file situation)) (defn with-file - "Return a situation with its file value replaced (the threaded result of - applying a transformation through the production change pipeline)." + "`situation` with its file replaced by `file'`." [situation file'] (assoc situation :file file')) (defn with-aux-files - "Return a situation carrying AUXILIARY files (a map of file-id -> file value) - beyond the primary `:file`. Used by cross-file configurations (e.g. a copy in - the primary/current file whose main lives in a linked LIBRARY file): the - primary `:file` stays the current file the role accessors resolve against, - while the auxiliary files travel alongside so an interpreter can install them - too (e.g. into the frontend store's `:files`, so cross-file sync can run). - The primary file is NOT included here." + "`situation` with auxiliary files (file id -> file), such as a linked + library, besides its current file. Roles resolve against the current file; + an interpreter installs the auxiliary ones next to it." [situation files-by-id] (assoc situation :aux-files files-by-id)) @@ -108,14 +70,10 @@ [situation] (get situation :aux-files {})) -;; ----- Node identity (central, no inheritance) ----------------------------- +;; ----- Node identity ------------------------------------------------------- ;; -;; Records are value-equal in Clojure, so two structurally-identical nodes would -;; collide as map keys. Each node therefore carries an explicit unique id under -;; the reserved key ::id, stamped at construction by `assign-id` (the single -;; thing every node constructor must call). The id machinery — stamping, and the -;; record/retrieve-by-id pair below — is implemented ONCE here and shared by all -;; nodes as plain functions; nodes never reimplement it, they just pass `this`. +;; Records with equal fields are equal, so every node constructor stamps a +;; unique id under ::id with `assign-id`; what a node records is keyed by it. (defn assign-id "Stamp a fresh unique id onto a node record (reserved key ::id). Every node @@ -131,9 +89,8 @@ ;; ----- Self-description, keyed by node identity ---------------------------- (defn- node-kind - "A short readable kind name for a node, derived from its record type (no - per-node boilerplate, faithful to the actual type). E.g. a ChangeAttr record - yields \"change-attr\"." + "The kebab-case name of a node's record type: a ChangeProperty record + yields \"change-property\"." [node] (let [cls (or #?(:clj (some-> ^Class (type node) .getSimpleName) :cljs (some-> node type .-name (str/split #"\.") last)) @@ -145,44 +102,30 @@ kebab)) (defn record-application - "Record what an operation `node` did into `situation`, keyed by the node's - identity, and append its id to the ordered :applied sequence. `record` is an - arbitrary map describing the application; the node retrieves it later via - `node-data` by passing itself. The node's kind (from its type) is merged in - under ::kind so the application can be rendered (see `describe-applied`) - without the node needing to name itself. Both consumers (inspection methods, - undo) read through node identity and ignore the extra ::kind key." + "Record in `situation` that `node` was applied, with `record`, a map of what + it did, under its identity (read back with `node-data`). The node's kind + goes in under ::kind for `describe-applied`." [situation node record] (-> situation (update :applied conj (node-id node)) (assoc-in [:node-data (node-id node)] (assoc record ::kind (node-kind node))))) (defn node-data - "The record that `node` wrote about its own application in `situation`, or nil - if it has not been applied. Keyed by node identity." + "What `node` recorded about its application in `situation`, or nil when it + was not applied." [situation node] (get-in situation [:node-data (node-id node)])) -(defn applied-ids - "The ordered vector of operation ids applied to the situation (the full - sequence, recoverable from the situation)." - [situation] - (:applied situation)) - (defn applied? - "Whether `operation` ran in this situation. Identity-based: true iff this exact - operation node (by its `::id`) recorded an application. Works through `optional` - / `one-of`: a chosen alternative records itself under its own identity, so - querying with the raw operation answers correctly. Bind an operation to a value - ONCE and reuse it (in the composition AND in any `Test` that queries it), so the - id you ask about is the id that ran." + "Whether this exact `operation` node ran in `situation`, also when it was + the chosen alternative of a `one-of` or `optional`. Bind an operation to a + value once and use that value both in the composition and in the query." [situation operation] (contains? (:node-data situation) (node-id operation))) (defn- render-application - "Render one (non-choice) application record as a short human-readable string. - Content-agnostic: uses ::kind and the record's own fields." + "One application record (not a choice) as a short readable line." [record] (let [kind (::kind record) args (dissoc record ::kind)] @@ -195,22 +138,17 @@ (some-> (node-data situation node) render-application)) (defn describe-applied - "A human-readable, ordered transcript of the operations that produced - `situation` — one line per application, in order. Built purely from the - situation's recorded :applied ids and :node-data records (each node's own - self-description), so it is faithful to what actually ran, including the branch - a one-of chose. Used to label failures with the exact sequence at hand." + "The transcript of the operations that produced `situation`, one line per + application in order, including the branch each one-of chose. Failures + are labelled with it." [situation] (let [node-data (:node-data situation)] (->> (:applied situation) (keep (fn [id] (let [record (get node-data id)] (if (contains? record :chosen) - ;; a one-of's choice record: if the chosen node recorded its - ;; own application, its own line (also in :applied) already - ;; tells the story — emit nothing to avoid a duplicate line. - ;; Only a non-recording choice (a skipped `optional`) is - ;; rendered here, so a skip stays visible in the transcript. + ;; a choice gets a line only when the chosen node has none + ;; of its own, such as a skipped `optional` (let [chosen (:chosen record)] (when-not (contains? node-data (::id chosen)) (str "one-of -> " (render-application {::kind (node-kind chosen)})))) @@ -218,18 +156,10 @@ (str/join "\n ")))) ;; ----- Role accessors ------------------------------------------------------ -;; -;; A setup records role bindings (meaningful named objects of the configuration) -;; as shape labels. `role-shape` resolves a role to the live shape in the current -;; file, with strict presence: an absent role throws diagnostically (never nil). -;; Specific named accessors (e.g. copy-instance) are thin wrappers, so tests read -;; `(copy-instance situation)` rather than knowing the role key. (defn role-shape - "Resolve role `role-key` to the live shape in the situation's current file, - using the id captured at setup time. Throws a diagnostic error if the role is - not bound, or if its captured shape is no longer present in the current page - (e.g. it was deleted) — never returns nil silently." + "The live shape of role `role-key` in the situation's current page. Throws + when the role is not bound or its shape is not in the page." [situation role-key] (let [id (get-in situation [:roles role-key]) page (thf/current-page (file situation))] @@ -254,9 +184,7 @@ (contains? (:roles situation) role-key)) (defn shape-by-id - "The live shape with `id` in the situation's current page (nil if absent). For - reading a shape whose id is held outside the role map — e.g. a field of a - tracked component object." + "The live shape with `id` in the situation's current page, or nil." [situation id] (ctst/get-shape (thf/current-page (file situation)) id)) @@ -281,53 +209,26 @@ :role role-key :id id}))))) -(defn rebind-role - "Re-point `role-key` to the current id of shape `label` (resolved via the global - label map now, while it is valid). Used by state-building operations that move - the configuration (e.g. `make-nested-component`) and must update where a role points so - that role-targeted operations keep acting on the intended shape." - [situation role-key label] - (assoc-in situation [:roles role-key] (thi/id label))) - -(defn rebind-role-id - "Like `rebind-role`, but re-points `role-key` to a shape `id` directly (when the - operation discovered the shape by id, e.g. by following a :shape-ref chain, - rather than by label)." - [situation role-key id] - (assoc-in situation [:roles role-key] id)) - ;; --------------------------------------------------------------------------- -;; Situation vars — arbitrary named values beyond roles -;; -;; Roles name SHAPES (resolved from labels to ids). Some operations need to track -;; named values that are NOT shapes — e.g. a component id to instantiate next, or -;; a counter (nesting depth). Those live in a separate `:vars` map so they do not -;; get confused with shape roles. Set/read with `set-var`/`get-var`. +;; Situation vars: named values that are not shapes, such as a component id +;; or a nesting count. ;; --------------------------------------------------------------------------- (defn set-var - "Associate `k` with `v` in the situation's `:vars` (arbitrary named values that - are NOT shapes — e.g. a component id, a counter). Returns the situation." + "`situation` with var `k` set to `v`." [situation k v] (assoc-in situation [:vars k] v)) (defn get-var - "Read the value of `k` from the situation's `:vars`, or `default` (nil if - omitted) when absent. See `set-var`." + "The value of var `k` in `situation`, or `default`." ([situation k] (get-var situation k nil)) ([situation k default] (get-in situation [:vars k] default))) (defn target-shape-id - "Resolve an operation's target to a shape id: - - a FUNCTION `(situation -> id)` is called with the situation (lets the target - be computed from situation state — e.g. a field of a tracked object — - resolved at apply-time so it follows state changes); - - a currently-bound ROLE resolves via the role (so the operation follows the - role as state-building ops re-point it); - - otherwise `target` is a label (strict-presence). - This is what makes a single operation composable across depth / with - make-nested-component et al." + "The shape id an operation's `target` names, resolved when the operation + applies: a `(situation -> id)` fn is called, a bound role gives its shape, + anything else is a label (strict presence)." [situation target] (cond (fn? target) (target situation) @@ -335,20 +236,13 @@ :else (resolve-shape-id situation target))) ;; --------------------------------------------------------------------------- -;; Strict-presence lookup -;; -;; Resolving a binding name (shape label) that is absent must throw a DIAGNOSTIC -;; error: it names the absent binding and lists those present. A silently-nil -;; lookup is forbidden (it would make a declarative case a lie / a green test -;; that asserts against nothing). Acting on a present-but-wrong-kind binding is -;; left to crash naturally downstream. +;; Strict-presence lookup: an absent label throws, naming the labels present, +;; so a case never asserts against nil. ;; --------------------------------------------------------------------------- (defn resolve-shape - "Resolve a shape binding name (label) to the actual shape in the situation's - current page, throwing a diagnostic error if the name is not bound to a shape - that exists in that page. The diagnostic lists the labels of the shapes that - ARE present, derived from the file itself (not from a parallel binding map)." + "The shape labelled `name` in the situation's current page. Throws, listing + the labels present, when there is none." [situation name] (let [the-file (file situation) page (thf/current-page the-file) @@ -367,72 +261,41 @@ shape)) (defn resolve-shape-id - "Resolve a shape binding name (label) to its uuid, with strict-presence - diagnostics (see `resolve-shape`)." + "The id of the shape labelled `name` (see `resolve-shape`)." [situation name] (:id (resolve-shape situation name))) ;; --------------------------------------------------------------------------- -;; Operation protocol -;; -;; An OPERATION is a step in a composition. Most operations TRANSFORM the -;; situation (an edit, a structural change, a nesting), but some do not (a `Test` -;; asserts and returns the situation unchanged; `Skip` is a no-op) — hence the -;; genus is "operation", not "transformation". An operation is reified as DATA (a -;; record), not a bare function, so it is printable and navigable. `apply-to` -;; takes the operation and a situation and returns a (possibly identical) -;; situation; it may also record its own application. The method cannot be named -;; `apply` (core clash). +;; Operation protocol: a step of a composition, as a record so it prints. +;; `apply-to` returns the situation after it, recording its application. ;; --------------------------------------------------------------------------- (defprotocol IOperation (apply-to [operation situation] - "Apply this operation to `situation`, returning a (possibly identical) - situation.")) - + "`situation` after this operation.")) ;; --------------------------------------------------------------------------- -;; Enumeration -;; -;; A composed operation may stand for MANY concrete cases (because `one-of` -;; offers alternatives). Enumeration turns one composed operation into the -;; sequence of fully-concrete operations it represents — each of which has -;; no remaining choice and can be `apply-to`'d directly. -;; -;; Enumeration is a generic-engine concern: only the composition operators -;; (`in-sequence`, `one-of`) implement it. Leaf/subject operations (e.g. the -;; component nodes) need not know about it — the top-level `enumerate` falls back -;; to "an operation with no choice enumerates to itself", so a plain node yields a -;; single variant (itself). This keeps `apply-to` and `enumerate` orthogonal and -;; keeps the `comp` node library free of enumeration code. +;; Enumeration: a composed operation stands for one concrete operation per +;; combination of its choices. Only the operators implement `IEnumerable`; any +;; other operation enumerates to itself. ;; --------------------------------------------------------------------------- (defprotocol IEnumerable (-enumerate [operation] - "Return a sequence of fully-concrete operations this one represents.")) + "The concrete operations, with no choice left, this one stands for.")) (defn enumerate - "The concrete operations represented by `operation`. Falls back to a single - variant (the operation itself) for anything that does not implement - IEnumerable (i.e. leaf operations with no internal choice)." + "The concrete operations `operation` stands for." [operation] (if (satisfies? IEnumerable operation) (-enumerate operation) [operation])) ;; --------------------------------------------------------------------------- -;; Composition operator: sequence -;; -;; A `Sequence` holds an ordered vector of child operations and applies them -;; left-to-right, THREADING the situation through each: the situation returned -;; by one child is the input to the next. Operations do not commute, so order -;; is explicit. Its enumeration is the CARTESIAN PRODUCT of its children's -;; variants (with single-variant children this is exactly one Sequence), which -;; is what makes a `one-of`/`optional` composed inside a sequence multiply the -;; case out into a matrix. -;; -;; The constructor is named `in-sequence` because `sequence` is a clojure.core -;; name and must not be shadowed. +;; Sequence: applies its steps in order, threading the situation. It +;; enumerates to the cartesian product of its steps' variants, which is what +;; multiplies a case out into a matrix. (`sequence` is a core name, hence +;; `in-sequence`.) ;; --------------------------------------------------------------------------- (declare ->Sequence) @@ -446,45 +309,30 @@ IEnumerable (-enumerate [_] - ;; Cartesian product: every combination of one concrete variant per step, - ;; each combination rewrapped as a concrete Sequence. With single-variant - ;; steps this yields exactly one Sequence (the all-singletons case). (->> steps - (map enumerate) ; step -> seq of concrete variants + (map enumerate) (reduce (fn [acc step-variants] (for [combo acc variant step-variants] (conj combo variant))) - [[]]) ; seed: one empty combination + [[]]) (map ->Sequence)))) (defn in-sequence - "Constructor for the sequence operator: apply `steps` (a seq of - transformations) in order, threading the situation through each." + "Constructor for the sequence operator: apply `steps` in order." [steps] (->Sequence (vec steps))) - ;; --------------------------------------------------------------------------- -;; Composition operator: one-of -;; -;; `one-of` offers a set of alternative transformations: it represents N cases, -;; one per alternative. It is a pure *enumeration* construct — it has no single -;; apply semantics, because applying it would mean arbitrarily picking one -;; alternative. So `apply-to` on a raw OneOf is an error; it must be enumerated -;; first (the runner does this). Its `-enumerate` is the UNION of its -;; alternatives' enumerations, so `one-of` composed inside `in-sequence` -;; multiplies out correctly via the sequence's cartesian product. +;; One-of: one case per alternative. It cannot be applied, only enumerated: +;; each variant is a `RecordedChoice` that records which alternative ran. ;; --------------------------------------------------------------------------- (declare record-choice) (defrecord RecordedChoice [one-of-id chosen] - ;; Internal node produced by OneOf enumeration. Applying it records, under the - ;; originating one-of's identity, which alternative was chosen, then applies - ;; that alternative. This is how `get-choice` (read by the test holding the - ;; one-of) recovers the choice from the resulting situation. It is already - ;; concrete, so it enumerates to itself. + ;; A variant of a one-of: records the choice under the one-of's identity + ;; (see `get-choice`), then applies the chosen operation. IOperation (apply-to [this situation] (->> (record-choice situation this) @@ -503,22 +351,16 @@ IEnumerable (-enumerate [this] - ;; Each alternative may itself enumerate to several concrete variants; every - ;; resulting concrete variant is wrapped so that, when applied, it records - ;; this one-of's choice under this one-of's identity. (for [alt alternatives variant (enumerate alt)] (->RecordedChoice (node-id this) variant)))) (defn one-of - "Constructor for the one-of operator: represents one case per alternative in - `alternatives`. Used to sweep a set of variants (e.g. several attribute - changes) across an otherwise-shared case. Carries an identity so the choice it - made in a given enumerated run can be recovered via `get-choice`." + "Constructor for the one-of operator: one case per alternative of + `alternatives`. Ask it which one ran with `get-choice`." [alternatives] (assign-id (->OneOf (vec alternatives)))) - (defrecord Skip [] IOperation (apply-to [_ situation] situation) @@ -526,18 +368,12 @@ (-enumerate [self] [self])) (defn skip - "The identity operation: applies as a no-op, enumerates to itself. The building - block of `optional`." + "The operation that changes nothing." [] (->Skip)) (defrecord Test [assert-fn] - ;; An operation that makes ASSERTIONS at this point in the sequence and leaves - ;; the situation unchanged. `assert-fn` is a (situation -> any) that performs the - ;; assertions itself (e.g. calls `t/is`), exactly like an external asserter — so - ;; checks can be placed at INTERMEDIATE steps, not only at the end. It records - ;; its application (so the transcript shows where checkpoints sit) but changes - ;; nothing. Concrete, so it enumerates to itself. + ;; Runs assertions at its point of the sequence and changes nothing. IOperation (apply-to [this situation] (assert-fn situation) @@ -546,60 +382,37 @@ (-enumerate [self] [self])) (defn test-that - "Constructor for an inline `Test` operation. `assert-fn` is a (situation -> any) - that performs assertions (it is run for side effects; its return is ignored). - Place it inside an `in-sequence` to assert at that point in the trajectory. - Typically queries `applied?`/`get-choice`/`has-property-of` to decide what to - assert for the current enumerated variant." + "Constructor for an inline assertion: `assert-fn` (situation -> any) runs + its assertions at this point of the sequence." [assert-fn] (assign-id (->Test assert-fn))) (defn optional - "`(optional t)` = `(one-of [t (skip)])`: sweeps WITH and WITHOUT `t` across a - case (two enumerated variants). Kept as its own named constructor for - readability. The workhorse for adding a state-building step (e.g. - `(optional (make-nested-component))`) as an axis over an existing case." + "`(one-of [t (skip)])`: the case with and without `t`." [t] (one-of [t (skip)])) (defn get-choice - "The alternative this `one-of` chose in `situation` (the concrete transformation - that actually ran for this branch), or nil if it did not run in this variant. - Recovered by node identity, so the test holds the one-of and asks it." + "The alternative `one-of` chose in `situation`, or nil when it did not run." [situation one-of] (:chosen (node-data situation one-of))) ;; --------------------------------------------------------------------------- -;; Executors -;; -;; Build a fresh situation from a setup thunk and apply a (possibly composed) -;; OPERATION. `run-variant` runs one already-concrete variant; `run-all` -;; enumerates a composed operation and runs every variant. Neither makes a -;; judgment or touches clojure.test — `check` (in -;; `frontend-tests.composable-tests.interpreter`) is the test-facing entry point. (Assertions can also live INSIDE the operation, via -;; `Test`; those fire as the operation is applied.) +;; Plain runners: apply operations only, with no sync, undo or judgment. The +;; component cases run through `comp.runner` or the frontend interpreter. ;; --------------------------------------------------------------------------- (defn run-variant - "Run one concrete (already-enumerated) variant: build a fresh situation via - `setup` (a 0-arg fn returning a *situation*) and apply `operation`, - returning the resulting situation. Makes no judgment. Exceptions propagate. - This is the per-variant step `check` builds on; tests use `check`, not this." + "The situation after applying the concrete `operation` to a fresh one from + `setup`." [{:keys [setup operation]}] (->> (setup) (apply-to operation))) - (defn run-all - "Enumerate `operation` into its concrete variants and run each (fresh setup - per variant, isolated label space — the id map is reset before each variant's - setup so per-variant setups don't clobber labels). Returns a vector of the - resulting situations, one per enumerated variant, in enumeration order. Makes - no judgment and does not touch clojure.test — see `check` (in - `frontend-tests.composable-tests.interpreter`) for the test-facing entry point that asserts. - - `run-variant-fn` runs one variant from `{:setup :operation}` (default - `run-variant`); other runners pass their own." + "The resulting situations of every variant of `operation`, in order, each + run by `run-variant-fn` (default `run-variant`) on `{:setup :operation}` + with a fresh label map." ([case-map] (run-all case-map run-variant)) ([{:keys [setup operation]} run-variant-fn] (->> (enumerate operation) @@ -608,18 +421,10 @@ (run-variant-fn {:setup setup :operation variant})))))) - (defn sequence-ops - "Flatten a CONCRETE (already-enumerated) operation into its ordered units. - Used by alternative interpreters (e.g. the frontend one) that dispatch - per-operation effects rather than calling `apply-to`. - - A concrete variant is a single operation record, or a `Sequence` of them, with - `RecordedChoice` (the enumerated form of a one-of) appearing where a one-of was. - `Sequence` is flattened; a `RecordedChoice` is KEPT as a unit (it carries both - the chosen operation and the one-of identity, so a per-op interpreter can - dispatch the chosen op's effect AND record the choice for `get-choice`). Use - `recorded-choice?`, `choice-of`, and `choice-one-of-id` to handle those units." + "The steps of the concrete `variant`, in order, with sequences flattened. A + `RecordedChoice` stays one step, so an interpreter can record the choice + (`record-choice`) and run the chosen operation (`choice-of`)." [variant] (cond (instance? Sequence variant) @@ -629,12 +434,12 @@ [variant])) (defn sequence? - "True if `op` is a `Sequence`; its ordered steps are under `:steps`." + "Whether `op` is a `Sequence`; its steps are under `:steps`." [op] (instance? Sequence op)) (defn recorded-choice? - "True if `op` is a one-of's enumerated choice wrapper." + "Whether `op` is a `RecordedChoice`, a variant of a one-of." [op] (instance? RecordedChoice op)) @@ -644,15 +449,13 @@ (:chosen recorded-choice)) (defn choice-one-of-id - "The identity of the one-of that produced this `RecordedChoice` (so a per-op - interpreter can record the choice under it, enabling `get-choice`)." + "The identity of the one-of a `RecordedChoice` comes from." [recorded-choice] (:one-of-id recorded-choice)) (defn record-choice "Record in `situation` the alternative `recorded-choice` selected, under its - one-of's identity, so `get-choice` finds it. Runners call it before applying - the chosen operation." + one-of's identity, for `get-choice`." [situation recorded-choice] (-> situation (assoc-in [:node-data (choice-one-of-id recorded-choice)] @@ -660,12 +463,8 @@ (update :applied conj (choice-one-of-id recorded-choice)))) ;; --------------------------------------------------------------------------- -;; Known failures -;; -;; A case assertion that a known bug breaks stays in the case as a strict -;; expected failure: it pins the wrong value the bug gives, so the case fails -;; when the failure changes or stops. Only the commit that fixes the bug -;; turns it back into a plain assertion. +;; Known failures: an assertion a known bug breaks pins the wrong value the +;; bug gives, so the case fails when the failure changes or stops. ;; --------------------------------------------------------------------------- (defn known-failure diff --git a/common/src/app/common/test_helpers/compositions.cljc b/common/src/app/common/test_helpers/compositions.cljc index a4fa6b748b..07bce3f9e7 100644 --- a/common/src/app/common/test_helpers/compositions.cljc +++ b/common/src/app/common/test_helpers/compositions.cljc @@ -19,6 +19,7 @@ [app.common.test-helpers.shapes :as ths] [app.common.types.container :as ctn] [app.common.types.shape :as cts] + [app.common.types.shape.layout :as ctl] [app.common.types.text :as txt])) ;; ----- File building @@ -83,6 +84,35 @@ (merge shape child-params))))) +(defn add-grid-frame + [file frame-label & {:keys [] :as params}] + ;; Generated shape tree: + ;; :frame-label [:name Frame1 :layout :grid], with no rows, columns or cells + (add-frame file frame-label (merge {:layout :grid + :layout-grid-dir :row + :layout-grid-rows [] + :layout-grid-columns [] + :layout-grid-cells {}} + params))) + +(defn place-in-grid-columns + "Give the grid frame `frame-label` one row and `columns` flex columns, and + put each child of it in `labels-by-column` (1-based column -> label) in + the cell of that column." + [file frame-label columns labels-by-column] + (let [frame (reduce (fn [frame _] (ctl/add-grid-column frame {:type :flex :value 1})) + (ctl/add-grid-row (ths/get-shape file frame-label) {:type :flex :value 1}) + (range columns)) + cells (reduce-kv (fn [cells column label] + (let [[id _] (d/seek #(= column (:column (val %))) cells)] + (assoc-in cells [id :shapes] [(thi/id label)]))) + (:layout-grid-cells frame) + labels-by-column)] + (-> file + (ths/update-shape frame-label :layout-grid-rows (:layout-grid-rows frame)) + (ths/update-shape frame-label :layout-grid-columns (:layout-grid-columns frame)) + (ths/update-shape frame-label :layout-grid-cells cells)))) + (defn add-minimal-component [file component-label root-label & {:keys [component-params root-params]}] diff --git a/common/test/common_tests/logic/composable_runner_test.cljc b/common/test/common_tests/logic/composable_runner_test.cljc index 4bc9ffed62..441a7b34eb 100644 --- a/common/test/common_tests/logic/composable_runner_test.cljc +++ b/common/test/common_tests/logic/composable_runner_test.cljc @@ -20,7 +20,7 @@ (t/use-fixtures :each thi/test-fixture) -(def ^:private original "#abcdef") +(def ^:private original setup/labeled-fill) (def ^:private red "#ff0000") (def ^:private green "#00ff00") @@ -28,14 +28,6 @@ [shape] (-> shape :fills first :fill-color)) -(t/deftest main-edit-syncs-to-clean-copy - (let [situation (r/run-variant - {:setup setup/simple-component-with-labeled-copy - :operation (n/change-property :main-child :fills red)}) - copy (setup/copy-instance situation)] - (t/is (= red (fill-of copy))) - (t/is (nil? (:touched copy))))) - (t/deftest main-edit-without-sync-leaves-copy-stale (let [situation (r/run-variant {:setup setup/simple-component-with-labeled-copy @@ -44,16 +36,6 @@ (t/is (= red (fill-of (setup/main-instance situation)))) (t/is (= original (fill-of (setup/copy-instance situation)))))) -(t/deftest copy-override-survives-main-edit - (let [situation (r/run-variant - {:setup setup/simple-component-with-labeled-copy - :operation (tm/in-sequence - [(n/change-property :copy-child :fills green) - (n/change-property :main-child :fills red)])}) - copy (setup/copy-instance situation)] - (t/is (= green (fill-of copy))) - (t/is (contains? (:touched copy) :fill-group)))) - (t/deftest sync-cascades-through-nested-components ;; The edit is on the deepest main. Its copy inside the outer main changes, ;; so the outer component syncs in a second pass and reaches the outer copy. @@ -190,13 +172,6 @@ (t/is (zero? (r/undo-depth situation))) (t/is (some? (tm/shape-by-id situation (n/lineage-copy-rect situation m)))))) -(t/deftest added-child-reaches-copy - (let [add (n/add-child :main-root :new-child) - situation (r/run-variant - {:setup setup/simple-component-with-copy - :operation add})] - (t/is (some? (n/materialized-instance-child add situation (setup/copy-root situation)))))) - (t/deftest undo-removes-added-child-from-main-and-copy (let [situation (r/run-variant {:setup setup/simple-component-with-copy @@ -320,7 +295,8 @@ (t/is (= original (level-fill situation m 0))) (t/is (zero? (r/undo-depth situation))))) -;; A user operation whose undo changes put back a different fill. +;; A user operation that changes the opacity of the copy root and whose +;; undo changes also rename it. (defrecord WrongUndoEdit [] n/IComponentOperation (op-kind [_] :user) @@ -348,7 +324,7 @@ (tm/record-application this {}))))) ;; A user operation that changes the file with no undo changes. -(defrecord UndoableEdit [] +(defrecord EditWithoutUndo [] n/IComponentOperation (op-kind [_] :user) @@ -387,18 +363,20 @@ :operation (->WrongUndoEdit)})] ;; the redo leaves the wrong name in place, and so does the variant undo (t/is (= [:undo :redo :variant-undo] (phases situation))) + (t/is (= (repeat 3 #{[:object :copy-root :name]}) + (map :signature (uc/failures situation)))) (t/is (= {:name "Wrong"} (-> (uc/failures situation) first :diff second :data :pages-index vals first :objects (get :copy-root)))))) (t/deftest round-trip-reports-a-change-with-no-undo-entry (let [situation (r/run-variant {:setup setup/simple-component-with-copy - :operation (->UndoableEdit)})] + :operation (->EditWithoutUndo)})] (t/is (= [:no-undo-entry] (phases situation))))) (t/deftest round-trip-can-be-turned-off (let [situation (r/run-variant {:setup setup/simple-component-with-copy - :operation (->UndoableEdit) + :operation (->EditWithoutUndo) :undo-check {:off "testing the switch"}})] (t/is (empty? (uc/failures situation))))) @@ -416,14 +394,6 @@ (t/is (empty? (uc/failures situation))) (t/is (= red (fill-of (tm/shape-by-id situation (n/lineage-rect situation m))))))) -(t/deftest failures-carry-what-differs - (let [situation (r/run-variant {:setup setup/simple-component-with-copy - :operation (->WrongUndoEdit)})] - (t/is (= [#{[:object :copy-root :name]} - #{[:object :copy-root :name]} - #{[:object :copy-root :name]}] - (mapv :signature (uc/failures situation)))))) - (t/deftest signature-names-what-differs (let [shape {:id (thi/new-id! :shape) :name "A" :opacity 1} other {:id (thi/new-id! :other) :name "B"} diff --git a/common/test/common_tests/logic/composable_sync_test.cljc b/common/test/common_tests/logic/composable_sync_test.cljc index 04f5351e44..aaa3308626 100644 --- a/common/test/common_tests/logic/composable_sync_test.cljc +++ b/common/test/common_tests/logic/composable_sync_test.cljc @@ -6,9 +6,9 @@ (ns common-tests.logic.composable-sync-test "Runs the shared composable component cases through the pure runner, on the - JVM and in JS. Case N and the rotation case need the frontend placement - step, and case X a pending frontend sync, so only the frontend interpreter - runs them." + JVM and in JS. The geometry cases (N, Z, AI and the rotation case) need + the frontend placement step and case X a pending frontend sync, so only + the frontend interpreter runs them." (:require [app.common.test-helpers.composable.comp.cases :as cases] [app.common.test-helpers.composable.comp.runner :as r] diff --git a/common/test/common_tests/logic/variants_switch_target_test.cljc b/common/test/common_tests/logic/variants_switch_target_test.cljc index 77cf315e54..c098fb6004 100644 --- a/common/test/common_tests/logic/variants_switch_target_test.cljc +++ b/common/test/common_tests/logic/variants_switch_target_test.cljc @@ -10,6 +10,7 @@ [app.common.files.changes-builder :as pcb] [app.common.logic.variants :as clv] [app.common.test-helpers.components :as thc] + [app.common.test-helpers.compositions :as tho] [app.common.test-helpers.files :as thf] [app.common.test-helpers.ids-map :as thi] [app.common.test-helpers.shapes :as ths] @@ -105,32 +106,11 @@ :first in the first column and a copy :copy01 of :c01 in the third, so the second cell is free." [file] - (let [file (-> file - (ths/add-sample-shape :board - :type :frame - :layout :grid - :layout-grid-dir :row - :layout-grid-rows [] - :layout-grid-columns [] - :layout-grid-cells {}) - (ths/add-sample-shape :first :parent-label :board) - (thc/instantiate-component :c01 :copy01 :parent-label :board)) - objects (:objects (thf/current-page file)) - board (-> (get objects (thi/id :board)) - (ctl/add-grid-row {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1}) - (ctl/add-grid-column {:type :flex :value 1})) - place (fn [cells column label] - (let [[id _] (d/seek #(= column (:column (val %))) cells)] - (assoc-in cells [id :shapes] [(thi/id label)]))) - cells (-> (:layout-grid-cells board) - (place 1 :first) - (place 3 :copy01))] - (-> file - (ths/update-shape :board :layout-grid-rows (:layout-grid-rows board)) - (ths/update-shape :board :layout-grid-columns (:layout-grid-columns board)) - (ths/update-shape :board :layout-grid-cells cells)))) + (-> file + (tho/add-grid-frame :board) + (ths/add-sample-shape :first :parent-label :board) + (thc/instantiate-component :c01 :copy01 :parent-label :board) + (tho/place-in-grid-columns :board 3 {1 :first 3 :copy01}))) (t/deftest swap-in-place-keeps-the-grid-cell (let [file (-> (thf/sample-file :file1) diff --git a/common/test/common_tests/runner.cljc b/common/test/common_tests/runner.cljc index fe84173113..a952548d22 100644 --- a/common/test/common_tests/runner.cljc +++ b/common/test/common_tests/runner.cljc @@ -184,8 +184,8 @@ 'common-tests.logic.text-touched-test 'common-tests.logic.token-apply-test 'common-tests.logic.token-test - 'common-tests.logic.variants-switch-test 'common-tests.logic.variants-switch-target-test + 'common-tests.logic.variants-switch-test 'common-tests.logic.variants-test 'common-tests.math-test 'common-tests.media-test diff --git a/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs b/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs index 829eeaee90..deefb59ce6 100644 --- a/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs +++ b/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs @@ -6,26 +6,14 @@ (ns frontend-tests.composable-tests.comp.sync-test "Runs the shared composable component cases - (`app.common.test-helpers.composable.comp.cases`) against the REAL app - (frontend interpreter). In-file propagation is AUTOMATIC: a case contains - ONLY the user edit(s) (no propagate op); the app's component-change watcher - syncs copies on its own, and that is what the cases assert. - - Async: each deftest uses `t/async`; `ftm/check` drives the store and calls - `done` when finished." + (`app.common.test-helpers.composable.comp.cases`) through the frontend + interpreter, where the app's component watcher syncs the copies." (:require [app.common.test-helpers.composable.comp.cases :as cases] [cljs.test :as t :include-macros true] [frontend-tests.composable-tests.interpreter :as ftm])) -;; Disable thumbnail rendering for the duration of each (async) test: the -;; propagation watcher schedules thumbnail renders that reach `window`, absent in -;; the headless runner. `:each` `:after` runs only after the test's `done` fires -;; (same guarantee the wasm-mock fixtures rely on), so the no-op covers the whole -;; async lifetime and is scoped to THIS namespace. See ftm/install-thumbnail-noop!. -(t/use-fixtures :each - {:before ftm/install-thumbnail-noop! - :after ftm/restore-thumbnail!}) +(t/use-fixtures :each ftm/fixture) (t/deftest case-b-copy-override-survives-later-main-change (t/async done (ftm/check done (cases/copy-override-survives-later-main-change)))) @@ -87,6 +75,9 @@ (t/deftest case-x-undo-before-sync-leaves-copies-unchanged (t/async done (ftm/check done (cases/undo-before-sync-leaves-copies-unchanged)))) +(t/deftest case-aj-reflow-after-nested-sync-is-its-own-undo-step + (t/async done (ftm/check done (cases/reflow-after-nested-sync-is-its-own-undo-step)))) + (t/deftest case-y-text-override-merges-with-main-text-change (t/async done (ftm/check done (cases/text-override-merges-with-main-text-change)))) diff --git a/frontend/test/frontend_tests/composable_tests/completion_contract_test.cljs b/frontend/test/frontend_tests/composable_tests/completion_contract_test.cljs index ab2c2f1420..af14ae9570 100644 --- a/frontend/test/frontend_tests/composable_tests/completion_contract_test.cljs +++ b/frontend/test/frontend_tests/composable_tests/completion_contract_test.cljs @@ -11,16 +11,12 @@ down on purpose, so a step that resolved early would see a half-synced file." (:require - [app.common.files.changes-builder :as pcb] - [app.common.logic.shapes :as cls] [app.common.test-helpers.composable.comp.nodes :as n] [app.common.test-helpers.composable.comp.setups :as setup] [app.common.test-helpers.composable.comp.undo-check :as uc] [app.common.test-helpers.composable.core :as tm] - [app.common.test-helpers.files :as thf] [app.common.test-helpers.ids-map :as thi] [app.common.test-helpers.shapes :as ths] - [app.main.data.changes :as dch] [app.main.data.workspace.libraries :as dwl] [app.main.data.workspace.reflow :as wrf] [app.main.data.workspace.shapes :as dwsh] @@ -32,13 +28,7 @@ [frontend-tests.helpers.mock :as mock] [potok.v2.core :as ptk])) -;; The watcher schedules thumbnail renders that reach `window`, absent -;; headless (see `ftm/install-thumbnail-noop!`). -(t/use-fixtures :each - {:before (fn [] - (thi/reset-idmap!) - (ftm/install-thumbnail-noop!)) - :after ftm/restore-thumbnail!}) +(t/use-fixtures :each ftm/fixture) (def ^:private original "#abcdef") (def ^:private red "#ff0000") @@ -68,33 +58,11 @@ [_] (rx/create (fn [_] nil))) -(defn- pause - [ms] - (js/Promise. (fn [resolve] (js/setTimeout resolve ms)))) - (defn- fill-main-child [color] (dwsh/update-shapes #{(thi/id :main-child)} #(assoc % :fills (ths/sample-fills-color :fill-color color)))) -(defn- fill-of - [label] - (-> (ths/get-shape (ftm/current-file) label) :fills first :fill-color)) - -(defn- raw-fill-commit - "A main child fill commit with `opts` merged into its params." - [opts] - (let [page (thf/current-page (ftm/current-file)) - changes (cls/generate-update-shapes - (pcb/empty-changes nil (:id page)) - #{(thi/id :main-child)} - #(assoc % :fills (ths/sample-fills-color :fill-color red)) - (:objects page) - {})] - (dch/commit-changes (merge {:redo-changes (:redo-changes changes) - :undo-changes (:undo-changes changes)} - opts)))) - (t/deftest ^:async edit-step-waits-for-slow-sync (let [sync-file dwl/sync-file] (await @@ -102,36 +70,35 @@ {dwl/sync-file (deferred-sync-file sync-file slow-sync)} (ftm/install! (setup/simple-component-with-labeled-copy)) (t/is (= :settled (await (ftm/await-step [(fill-main-child red)])))) - (t/is (= red (fill-of :copy-child))))))) + (t/is (= red (ftm/fill-of :copy-child))))))) (t/deftest ^:async undo-and-redo-steps-follow-a-slow-sync ;; Undo must find the slow sync already committed: it reverts the edit and - ;; its sync together only when both are on the undo stack. The pause after - ;; the undo step lets any work that outlived the edit step land. + ;; its sync together only when both are on the undo stack. (let [sync-file dwl/sync-file] (await (mock/with-mocks* {dwl/sync-file (deferred-sync-file sync-file slow-sync)} (ftm/install! (setup/simple-component-with-labeled-copy)) (await (ftm/await-step [(fill-main-child red)])) + (t/is (= red (ftm/fill-of :copy-child)) "the edit step ends synced") (t/is (= :settled (await (ftm/await-step [dwu/undo])))) - (await (pause (* 2 sync-delay-ms))) - (t/is (= original (fill-of :main-child))) - (t/is (= original (fill-of :copy-child))) + (t/is (= original (ftm/fill-of :main-child))) + (t/is (= original (ftm/fill-of :copy-child))) (t/is (= :settled (await (ftm/await-step [dwu/redo])))) - (t/is (= red (fill-of :main-child))) - (t/is (= red (fill-of :copy-child))))))) + (t/is (= red (ftm/fill-of :main-child))) + (t/is (= red (ftm/fill-of :copy-child))))))) (defn- watch-touches - "Count the `touch-component` events emitted from now on. Returns - `[count-atom subscription]`." + "Collect the ids of the components that `touch-component` events touch from + now on. Returns `[ids-atom subscription]`." [] - (let [touches (atom 0) + (let [touched (atom #{}) sub (rx/sub! (rx/filter (ptk/type? ::dwl/touch-component) st/stream) - (fn [_] (swap! touches inc)))] - [touches sub])) + (fn [event] (swap! touched into @event)))] + [touched sub])) (t/deftest ^:async undo-and-redo-steps-wait-for-the-watcher ;; Undo and redo start no sync: the watcher only touches the component, a @@ -139,19 +106,21 @@ ;; would finish before that touch. (ftm/install! (setup/simple-component-with-labeled-copy)) (await (ftm/await-step [(fill-main-child red)])) - (let [[touches sub] (watch-touches)] + (let [component #{(thi/id :component1)} + [touched sub] (watch-touches)] (t/is (= :settled (await (ftm/await-step [dwu/undo])))) - (t/is (= 1 @touches) "the undo step waited for the watcher") + (t/is (= component @touched) "the undo step waited for the watcher") + (reset! touched #{}) (t/is (= :settled (await (ftm/await-step [dwu/redo])))) - (t/is (= 2 @touches) "the redo step waited for the watcher") + (t/is (= component @touched) "the redo step waited for the watcher") (rx/dispose! sub))) (t/deftest ^:async dropped-commit-steps-settle ;; Translation and derived commits start no sync; their steps must still ;; resolve. (ftm/install! (setup/simple-component-with-labeled-copy)) - (t/is (= :settled (await (ftm/await-step [(raw-fill-commit {:translation? true})])))) - (t/is (= :settled (await (ftm/await-step [(raw-fill-commit {:skip-component-sync? true})]))))) + (t/is (= :settled (await (ftm/await-step [(ftm/fill-commit :main-child red {:translation? true})])))) + (t/is (= :settled (await (ftm/await-step [(ftm/fill-commit :main-child red {:skip-component-sync? true})]))))) (defn- run-endless-step "Install a component whose sync never finishes and run a main edit step with @@ -174,7 +143,7 @@ (ftm/install! (setup/simple-component-with-labeled-copy)) (t/is (empty? (wrf/pending))) (t/is (= :settled (await (ftm/await-step [(fill-main-child red)])))) - (t/is (= red (fill-of :copy-child)))) + (t/is (= red (ftm/fill-of :copy-child)))) (t/deftest skipped-optional-keeps-the-undo-baseline ;; The end-of-variant round trip undoes back to the last file install. A diff --git a/frontend/test/frontend_tests/composable_tests/interpreter.cljs b/frontend/test/frontend_tests/composable_tests/interpreter.cljs index 099a7e9569..6526a1952d 100644 --- a/frontend/test/frontend_tests/composable_tests/interpreter.cljs +++ b/frontend/test/frontend_tests/composable_tests/interpreter.cljs @@ -5,46 +5,24 @@ ;; Copyright (c) KALEIDOS SUBSIDIARY SL (ns frontend-tests.composable-tests.interpreter - "FRONTEND interpreter + test-facing `check` for the composable test model. - - The generic engine lives in `app.common.test-helpers.composable.core` and the - component instruments (operation records, setups, role accessors, inspection - methods) behind the `comp` boundary. What lives HERE is: - 1. `op->events` — the event realisation of each EVENT-op: the real - workspace event(s) it dispatches (it depends on - `app.main.data.workspace.*`). - 2. an ASYNC interpreter that drives a sequence of operations through the REAL - app: it installs the situation's file into the global store, starts the - real component-change watcher, then for each operation dispatches its - event(s) and AWAITS all pending work it caused (`await-step`: the - watcher's sync wait and layout/text reflow, so the app's AUTOMATIC - propagation — not a manual sync — is what runs), re-reading the file - from the store after each. A step that does not settle in time fails. - 3. `check` — the test-facing entry: takes {:setup :operation} + an OPTIONAL - asserter; enumerates the operation and runs each variant; assertions may - be inline (`Test` ops) and/or in the asserter. - - IN-FILE PROPAGATION IS AUTOMATIC: there is no propagate operation. The watcher - (`dwl/watch-component-changes`), running on the global store, detects - main-instance changes in the CURRENT file and syncs that file's copies on its - own. That automatic behaviour is precisely what the cases exercise. The one - deliberate exception is CROSS-FILE propagation (case H): when the main lives - in a linked LIBRARY and the copy in the consuming file, the watcher does NOT - cross the file boundary — the real app propagates via the library-UPDATE - action, so the `SyncFromLibrary` op explicitly dispatches `sync-file` (this is - faithful: it is exactly the user action, not a test shortcut). See - `mem:frontend/composable-component-tests`. - - NOTE on the store: this uses the GLOBAL `st/state` store (not the isolated - `setup-store`), because the watcher reads `refs/workspace-data` which derives - from `st/state`. State is re-installed per variant for isolation." + "Runs composable component cases through the frontend (see + `mem:frontend/composable-component-tests`). It installs the situation's + files in the global store (the component watcher reads it through + `app.main.refs`), starts the workspace watchers, maps each user operation + to the workspace events a user action dispatches (`op->events`) and waits + for the work they cause (`await-step`). The app's own watcher syncs the + copies; only the library update of case H is an explicit `sync-file`, as + in the app. `check` is the test entry point." (:require + [app.common.files.changes-builder :as pcb] + [app.common.logic.shapes :as cls] [app.common.test-helpers.composable.comp.nodes :as n] [app.common.test-helpers.composable.comp.undo-check :as uc] [app.common.test-helpers.composable.core :as tm] [app.common.test-helpers.files :as cthf] [app.common.test-helpers.ids-map :as cthi] [app.common.test-helpers.shapes :as cths] + [app.main.data.changes :as dch] [app.main.data.workspace :as dw] [app.main.data.workspace.libraries :as dwl] [app.main.data.workspace.reflow :as wrf] @@ -65,18 +43,8 @@ [potok.v2.core :as ptk])) ;; -------------------------------------------------------------------------- -;; (0) Thumbnail rendering — disabled in this headless suite -;; -;; The propagation watcher we start (`dwl/watch-component-changes`) ALSO schedules -;; THUMBNAIL renders on every component change (its `component-changed` event has a -;; thumbnail branch). Thumbnail rendering reaches `app.util.dom/get-css-variable`, -;; which calls `window.getComputedStyle` — and there is no `window` in the headless -;; runner, so a (queued, async) render fires LATER and crashes the run. Thumbnails -;; are pure UI side-effect, irrelevant to what we test, so we stub the public seam -;; `dwth/update-thumbnail` to a no-op event for the duration of OUR tests (installed -;; / restored by a `:each` fixture in the case namespace — the same `set!`-and- -;; restore pattern as `frontend_tests.helpers.wasm`, whose `:after` correctly runs -;; only after each async test's `done`). Scope is thus our suite only. +;; Thumbnails: the component watcher renders them, which reaches `window`, +;; absent headless, so tests stub `dwth/update-thumbnail` (see `fixture`). ;; -------------------------------------------------------------------------- (defonce ^:private original-update-thumbnail (atom nil)) @@ -102,70 +70,31 @@ (set! dwth/update-thumbnail orig) (reset! original-update-thumbnail nil))) -;; -------------------------------------------------------------------------- -;; (1) Frontend realisation of operations: op record -> workspace event(s) -;; -;; The operation's "what" (its update-fn / target) is shared in common; this maps -;; it to the "how" on the frontend — the real event a user interaction dispatches. -;; Returns a vector of events to emit for that operation. -;; -------------------------------------------------------------------------- +(def fixture + "An `:each` fixture for tests that run the component watcher: a fresh label + map and no thumbnail rendering. Its `:after` runs after an async test's + `done`, so it covers the whole test." + {:before (fn [] + (cthi/reset-idmap!) + (install-thumbnail-noop!)) + :after restore-thumbnail!}) -;; The edit a ChangeProperty performs is the SHARED `n/set-property`, so the -;; frontend applies the identical change the common node does (only the wrapping -;; differs: a real workspace event here vs. apply-changes there). - -(defn- add-child->shape - "Build the shape value AddChild introduces, parented under the target parent in - the current store page (mirrors the common add-child's sample shape). Returns - the shape with parent/frame set to the target parent." - [parent-label new-label shape-params] - (let [parent-id (cthi/id parent-label) - shape (cths/sample-shape new-label (or shape-params {}))] - (assoc shape - :parent-id parent-id - :frame-id parent-id))) +;; -------------------------------------------------------------------------- +;; Operations as workspace events +;; -------------------------------------------------------------------------- (defn op->events - "Map a comp operation record to the real workspace event(s) it dispatches. - `op` is one of the comp node records (app.common.test-helpers.composable.comp.nodes); - `situation` provides cross-file context (e.g. the library id) for ops that need - it. - - Each operation is realised with the SAME production change builder the common - node uses, but wrapped in the real workspace event (so it commits to the store - and the watcher auto-propagates): - ChangeProperty -> update-shapes (generate-update-shapes; n/set-property) - EditText -> v2-update-text-shape-content (n/edit-text-content) - MoveShape -> update-position (sidebar, page coordinates) - MoveChild -> relocate-shapes (generate-relocate, existing shape) - AddChild -> add-shape (create a shape under the parent) - RemoveChild -> delete-shapes (generate-delete-shapes) - Detach -> detach-component (generate-detach-component) - UpdateMain -> update-component-sync (generate-sync-shape-inverse) - DeleteComponent -> delete-component (generate-delete-shapes on the main) - RestoreComponent -> restore-component (generate-restore-component) - Duplicate -> duplicate-shapes (generate-duplicate-changes) - NestCopy -> relocate-shapes (generate-relocate into a main) - SwapShape -> component-swap (any copy head) - MoveToCell -> update-shapes on the grid board (n/move-to-cell-fn) - SyncFromLibrary -> sync-file (the cross-file library-update action, H) - Undo -> dwu/undo (reverse the previous operation(s), I) - Redo -> dwu/redo (apply the undone operation(s) again) - UndoBeforeSync -> update-shapes + dwu/undo, emitted together - (In-file propagation is automatic — the watcher — so no propagate op exists.)" + "The workspace events a user action dispatches for the comp operation `op`, + built from `situation` and from the same helpers the common node uses." [op situation] (cond (instance? n/ChangeProperty op) (let [{:keys [target property value]} op] - ;; `target` may be a ROLE (resolved via the situation, so the edit follows - ;; the role as make-nested-component re-points it) or a label — same dual resolution - ;; as the common ChangeProperty. The edit uses the SHARED `n/set-property`. [(dwsh/update-shapes #{(tm/target-shape-id situation target)} (fn [shape] (n/set-property shape property value)))]) (instance? n/EditText op) - ;; The commit the text editor makes when the edit ends (on blur), SVG - ;; renderer path. + ;; the text editor's commit on blur, SVG renderer path (let [{:keys [target edit value]} op id (tm/target-shape-id situation target) shape (tm/shape-by-id situation id) @@ -178,37 +107,22 @@ :original-content (:content shape))]) (instance? n/Rotate op) - ;; The real sidebar rotation event, absolute mode: rotates the shape (and its - ;; whole subtree) around its center. Its apply-modifiers step runs the - ;; placement-vs-override classification for component copies (check-delta), - ;; which is part of what a case using `rotate` exercises. + ;; the sidebar rotation, which decides what it touches in copies (check-delta) (let [{:keys [target angle]} op] [(dwt/increase-rotation [(tm/target-shape-id situation target)] angle)]) (instance? n/MoveShape op) - ;; The real sidebar position event, in page coordinates. + ;; the sidebar position, in page coordinates (let [{:keys [target dx dy]} op id (tm/target-shape-id situation target) {:keys [x y]} (:selrect (tm/shape-by-id situation id))] [(dwt/update-position id {:x (+ x dx) :y (+ y dy)} {:absolute? true})]) (instance? n/ChangeHeight op) - ;; The real sidebar dimension event. + ;; the sidebar height (let [{:keys [target value]} op] [(dwt/update-dimensions [(tm/target-shape-id situation target)] :height value)]) - (instance? n/SwapComponent op) - ;; Swap lineage `name`'s nesting level `level` for lineage `target`'s component - ;; via the REAL swap event (dwl/component-swap), so it commits through the - ;; normal path and the watcher AUTOMATICALLY propagates the swap to copies - ;; (incl. the deeper nesting levels). This is the behaviour under test. - (let [{:keys [name level target keep-touched?]} op - file-id (:id (tm/file situation)) - nested (n/lineage-nesting situation name level) - shape (tm/shape-by-id situation (:nested-head nested)) - target-id (n/lineage-component-id situation target)] - [(dwl/component-swap shape file-id target-id (boolean keep-touched?))]) - (instance? n/SwapShape op) (let [{:keys [target to keep-touched?]} op] [(dwl/component-swap (tm/shape-by-id situation (tm/target-shape-id situation target)) @@ -217,20 +131,13 @@ (boolean keep-touched?))]) (instance? n/MoveToCell op) - ;; The board's new cells, as the commit of a canvas drop into the cell. + ;; the board's new cells, as a canvas drop commits them (let [{:keys [board child row column]} op] [(dwsh/update-shapes #{(tm/target-shape-id situation board)} (n/move-to-cell-fn (tm/target-shape-id situation child) row column) {:with-objects? true})]) (instance? n/SwitchVariant op) - ;; The variant-switch action: switch the resolved variant copy head to the - ;; sibling member whose selector property (pos 0) has `value`, via the REAL - ;; `variants-switch` event (which discovers the sibling in the variant container - ;; and routes through component-swap keep-touched? true, so the watcher - ;; auto-propagates the switch across nesting levels exactly like a swap). `target` - ;; uses the standard resolution (role | label | (situation -> id) fn), so the op - ;; is structure-blind. (let [{:keys [target value]} op head-id (tm/target-shape-id situation target) shape (tm/shape-by-id situation head-id)] @@ -263,40 +170,34 @@ (instance? n/MoveChild op) (let [{:keys [target parent to-index]} op] - [(dwsh/relocate-shapes #{(cthi/id target)} (cthi/id parent) to-index)]) + [(dwsh/relocate-shapes #{(tm/resolve-shape-id situation target)} + (tm/resolve-shape-id situation parent) + to-index)]) (instance? n/RemoveChild op) - (let [{:keys [target]} op] - [(dwsh/delete-shapes #{(cthi/id target)})]) + [(dwsh/delete-shapes #{(tm/resolve-shape-id situation (:target op))})] (instance? n/AddChild op) - (let [{:keys [parent new-label shape-params]} op] - [(dwsh/add-shape (add-child->shape parent new-label shape-params) + (let [{:keys [parent new-label shape-params]} op + parent (tm/resolve-shape situation parent)] + [(dwsh/add-shape (n/child-shape parent new-label shape-params) {:no-select? true})]) (instance? n/SyncFromLibrary op) - ;; The cross-file library-update action: sync the current (consuming) file - ;; from its linked library — exactly what the "library updated" dialog does. - (let [file-id (:current-file-id @st/state) - library-id (first (keys (tm/aux-files situation)))] - [(dwl/sync-file file-id library-id)]) + ;; the library update the "library updated" dialog runs + [(dwl/sync-file (:current-file-id @st/state) (n/library-id situation))] (instance? n/Undo op) - ;; Reverse the previous operation(s) via the real undo event, once per - ;; operation to undo. The workspace undo stack was maintained automatically - ;; by the prior ops' commits. (vec (repeat (:times op) dwu/undo)) (instance? n/UndoBeforeSync op) - ;; The edit and the undo go out together, so the undo commits before the - ;; watcher inspects the edit's commit. + ;; emitted together, so the undo commits before the watcher inspects the edit (let [{:keys [target property value]} op] [(dwsh/update-shapes #{(tm/target-shape-id situation target)} (fn [shape] (n/set-property shape property value))) dwu/undo]) (instance? n/Redo op) - ;; Apply again the latest undone operation(s) via the real redo event. [dwu/redo] :else @@ -304,19 +205,16 @@ {:op op})))) ;; -------------------------------------------------------------------------- -;; (2) Async interpreter +;; Interpreter ;; -------------------------------------------------------------------------- ;; Longest a step may take to settle; a step that takes longer fails. (def ^:private step-timeout-ms 2000) (defn- install-situation-event - "An UpdateEvent installing the situation's files into the (global) store: the - primary file as the current/workspace file, plus any AUXILIARY files (e.g. a - linked library, for the cross-file case H) alongside in `:files`, each tagged - `:library-of` the current file so the library-sync machinery treats them as - linked libraries. The undo stack starts empty, so an undo never reaches the - previous variant's entries." + "An event that installs the situation's file as the current one, its + auxiliary files as linked libraries, and an empty undo stack, so an undo + never reaches the previous variant's entries." [situation] (let [file (tm/file situation) aux (tm/aux-files situation)] @@ -333,20 +231,37 @@ aux)))))) (defn current-file - "Read the live workspace file out of the global store." + "The current file in the global store." [] (let [st @st/state] (get-in st [:files (:current-file-id st)]))) +(defn fill-of + "The fill color of the shape `label` in the live file." + [label] + (-> (cths/get-shape (current-file) label) :fills first :fill-color)) + +(defn fill-commit + "A commit that fills the shape `label` of the live file with `color`, with + `opts` merged into the commit params." + [label color opts] + (let [page (cthf/current-page (current-file)) + changes (cls/generate-update-shapes + (pcb/empty-changes nil (:id page)) + #{(cthi/id label)} + #(assoc % :fills (cths/sample-fills-color :fill-color color)) + (:objects page) + {})] + (dch/commit-changes (merge {:redo-changes (:redo-changes changes) + :undo-changes (:undo-changes changes)} + opts)))) + (defn await-step - "Emit `events` into the global store and return a promise that resolves with - `:settled` once every pending work has drained: component sync (the - watcher's wait for each commit and the sync it starts) and layout and text - reflow, as tracked by `app.main.data.workspace.reflow`. It waits the way the - plugin `waitForLayoutUpdate` does. When `timeout-ms` (default - `step-timeout-ms`) passes first, it resolves with `{:timeout pending}`, the - work still pending then. Relies on every producer opening its pending work - synchronously while the events are processed." + "Emit `events` and return a promise of `:settled` once the pending work of + `app.main.data.workspace.reflow` drains (component sync, layout and text + reflow), as the plugin `waitForLayoutUpdate` waits; or of + `{:timeout pending}` after `timeout-ms` (default `step-timeout-ms`). Work + must be opened while the events are processed." ([events] (await-step events step-timeout-ms)) ([events timeout-ms] (doseq [e events] (st/emit! e)) @@ -375,12 +290,9 @@ situation)) (defn- record-op - "Record an operation's application onto the situation (after its effect settled), - re-reading the file from the store. The record is the op's own fields, plus - its `n/applied-result` when it has one. For a RecordedChoice (one-of), record - the choices first, under their one-of identities (so the asserter's - `get-choice` works), and then the chosen op's application, in the order - `RecordedChoice`'s own `apply-to` uses." + "`situation` with the live file and the application of the settled op unit + `op`: its choices first, then the op's own fields and its + `n/applied-result`, if any." [situation op] (let [before (tm/file situation) situation (-> situation @@ -393,16 +305,13 @@ (tm/record-application situation op record))) (defn- op-events - "The workspace events to dispatch for an op unit (a plain op or a one-of's - RecordedChoice — for the latter, the chosen op's events). `situation` provides - cross-file context to ops that need it." + "The workspace events of the op unit `op` (for a choice, of the chosen op)." [op situation] (op->events (unwrap op) situation)) (defn- install-file-event - "An UpdateEvent that replaces the current file in the (global) store with `file` - (keeping aux files and everything else). Used to write back the result of a - FILE-TRANSFORMING op (see `file-op?`)." + "An event that makes `file` the current file in the store, the result of a + `sync-op?` operation." [file] (ptk/reify ::install-file ptk/UpdateEvent @@ -415,12 +324,10 @@ ;; -------------------------------------------------------------------------- ;; Undo/redo round trip (see `app.common.test-helpers.composable.comp.undo-check`) ;; -;; Run on every user step that goes through a real event: undo must give back -;; the file before the step and redo the file after it, each moving the -;; workspace undo index back to where it was, so a step adds exactly one undo -;; entry (or group). File installs (assembly steps and the reset, see -;; `sync-op?`) add no entry, so they are the baseline the end-of-variant round -;; trip undoes back to. +;; Run on every user step that dispatches events: undo gives back the file +;; and the undo index before the step, redo those after it, so a step adds +;; exactly one undo entry or group. File installs (`sync-op?`) add none and +;; are the baseline the end-of-variant round trip undoes back to. ;; -------------------------------------------------------------------------- (defn- undo-index @@ -515,35 +422,19 @@ (js/Promise.resolve situation)))) (defn- sync-op? - "Whether `op` is a SYNCHRONOUS, `apply-to`-based operation rather than one that - dispatches a workspace event and needs settling. Two kinds: - - FILE-TRANSFORMING: the `:assembly` nodes (see `n/IComponentOperation`) and - `skip`, which arrange the CONFIGURATION (create, nest, instantiate, - re-point roles) — applied by running `apply-to` against the live store - file and writing the result back. The property under test is still - exercised by the SUBSEQUENT real-event ops. - - `Test`: an inline assertion checkpoint — its `apply-to` runs the assertion - against the current situation and returns it unchanged. - Both are handled by `run-sync-op` (no async settle — any store write is a - synchronous UpdateEvent)." + "Whether the op unit `op` runs its `apply-to` on the live file instead of + dispatching events: assembly nodes, the reset, `skip` and inline tests." [op] (let [op (unwrap op)] (or (instance? tm/Skip op) (instance? tm/Test op) (= :assembly (n/op-kind op)) - ;; A user operation, but the real reset event transitively reads browser - ;; globals (CSS vars), so it cannot run headless; the shared apply-to runs - ;; the production reset generator with validation off. - (instance? n/ResetCopyInstance op) + ;; a user operation, but the real reset event reads browser globals (instance? n/ResetOverrides op)))) (defn- run-sync-op - "Apply a synchronous (`sync-op?`) operation: run its shared `apply-to` against a - situation whose `:file` is the live store file, write the resulting file back - into the store, and return the updated situation (with any re-pointed roles). - For `Test` this runs the inline assertion (against the live store state) and the - file is unchanged; for `make-nested-component`/`skip` it writes back the transformed file. - Synchronous." + "Run the `apply-to` of the `sync-op?` op unit `op` on the live file and + install the result. Returns the situation." [situation op] (let [situation (tm/with-file situation (current-file)) situation (tm/apply-to op situation)] @@ -557,14 +448,10 @@ (mark-baseline)))) (defn- run-ops - "Async fold over `ops` (concrete operation units, in order — plain ops and/or - one-of RecordedChoice wrappers). Threads the situation. A SYNCHRONOUS op - (`sync-op?` — file-transforming or an inline `Test`) is applied synchronously - via `apply-to`; every other op dispatches its real workspace event(s) and - awaits all pending work (`await-step`). The file is re-read from the store - after each. Calls `k` with the final situation, or with nil when a step did - not settle in time; that step fails the test, naming the work still - pending." + "Run the op units `ops` in order, each `sync-op?` one on the live file and + the others as events awaited with `await-step`. Calls `k` with the final + situation, or with nil after failing the test when a step did not + settle." [situation ops k] (if (empty? ops) (k situation) @@ -602,14 +489,9 @@ (k nil))))))))) (defonce ^:private original-store - ;; Captured at namespace-LOAD time — i.e. before any test in the run executes. - ;; Several test namespaces (the plugins suite) `set!` st/state / st/stream to - ;; isolated stores and never restore them. That silently kills this harness: - ;; the refs in `app.main.refs` (through which `watch-component-changes` - ;; observes commits) are okulary lenses bound to THIS atom instance at load - ;; time, so once the var points elsewhere, our events commit to a store the - ;; watcher does not see and propagation dies with no error. Re-installing the - ;; original per variant makes the harness immune to run order. + ;; The store at load time. Some test namespaces `set!` st/state and + ;; st/stream and never restore them, while the `app.main.refs` lenses the + ;; component watcher reads stay bound to these atoms. {:state st/state :stream st/stream}) (defn- restore-global-store! @@ -662,7 +544,7 @@ trip of each user step and of the variant. Calls `k` with the final situation, or nil when a step did not settle." [setup ops undo-check? k] - ;; fresh label space per variant (mirrors the pure `tm/run-all`) + ;; a fresh label map per variant, as `tm/run-all` does (cthi/reset-idmap!) (let [situation (-> (setup) (assoc ::undo-check? undo-check?) @@ -676,31 +558,15 @@ (k situation)))))) ;; -------------------------------------------------------------------------- -;; (3) Test-facing check +;; Test entry point ;; -------------------------------------------------------------------------- (defn check - "Frontend `check`: run `case-map` ({:setup :operation}) through the REAL app and, - if `asserter` is given, apply it (a situation -> any fn performing assertions) - to the resulting situation of EACH enumerated variant. Async — `done` is the - cljs.test async callback and MUST be called when finished. - - Each variant also runs the undo/redo round trip, asserted after the - asserter (see `app.common.test-helpers.composable.comp.undo-check`; the - case map's `:undo-check` turns it off or marks known failures). - - Assertions may be INLINE (via `Test` operations in the `:operation` sequence, - firing as the op runs) and/or via the trailing `asserter`; `asserter` is - optional (omit when all assertions are inline). The asserter closes over node - references the test holds (e.g. `has-property-of` on a change node). In-file - propagation is AUTOMATIC (the watcher) — no propagate op is added. - - Mocks are installed for the duration of the check: `rp/cmd!` returns - success (recording calls) and `rx/timer` fires instantly, so the - `SyncFromLibrary` op's delayed RPC does not produce network errors. - - Arities: `(check done case-map)`, which takes the asserter from the case - map's `:asserter`, or `(check done case-map asserter)`." + "Run every variant of `case-map` through the frontend, apply `asserter` + (default the case map's `:asserter`) to each result and check its undo/redo + round trip (`app.common.test-helpers.composable.comp.undo-check`). Calls the + async test's `done` at the end. RPC calls are mocked and `rx/timer` fires + at once, for the delayed RPC of the library update." ([done case-map] (check done case-map (:asserter case-map))) ([done {:keys [setup operation] :as case-map} asserter] (mock/with-mocks @@ -713,9 +579,6 @@ (inner-done) (run-variant setup - ;; a variant is a composed operation; flatten to its ordered leaf - ;; ops. `enumerate` already removed all one-of choices, so the - ;; variant is a Sequence (or a single op). (tm/sequence-ops (first vs)) (uc/enabled? case-map) (fn [situation] diff --git a/frontend/test/frontend_tests/data/changes_test.cljs b/frontend/test/frontend_tests/data/changes_test.cljs index 11783fde85..6dbbcfa21a 100644 --- a/frontend/test/frontend_tests/data/changes_test.cljs +++ b/frontend/test/frontend_tests/data/changes_test.cljs @@ -15,13 +15,7 @@ [cljs.test :as t :include-macros true] [frontend-tests.composable-tests.interpreter :as ftm])) -;; The component watcher schedules thumbnail renders that reach `window`, -;; absent headless (see `ftm/install-thumbnail-noop!`). -(t/use-fixtures :each - {:before (fn [] - (thi/reset-idmap!) - (ftm/install-thumbnail-noop!)) - :after ftm/restore-thumbnail!}) +(t/use-fixtures :each ftm/fixture) (t/deftest change-without-page-leaves-the-pages-alone (t/async done diff --git a/frontend/test/frontend_tests/data/workspace_edit_watchers_test.cljs b/frontend/test/frontend_tests/data/workspace_edit_watchers_test.cljs index 1f8eec6a2b..a4c0691f54 100644 --- a/frontend/test/frontend_tests/data/workspace_edit_watchers_test.cljs +++ b/frontend/test/frontend_tests/data/workspace_edit_watchers_test.cljs @@ -18,13 +18,7 @@ [cljs.test :as t :include-macros true] [frontend-tests.composable-tests.interpreter :as ftm])) -;; The watcher schedules thumbnail renders that reach `window`, absent -;; headless (see `ftm/install-thumbnail-noop!`). -(t/use-fixtures :each - {:before (fn [] - (thi/reset-idmap!) - (ftm/install-thumbnail-noop!)) - :after ftm/restore-thumbnail!}) +(t/use-fixtures :each ftm/fixture) (defn- undo-entries-for-an-edit "Install a component with a copy, start the edit watchers `starts` times, diff --git a/frontend/test/frontend_tests/data/workspace_sync_barrier_test.cljs b/frontend/test/frontend_tests/data/workspace_sync_barrier_test.cljs index a610a5b32d..03f0485efe 100644 --- a/frontend/test/frontend_tests/data/workspace_sync_barrier_test.cljs +++ b/frontend/test/frontend_tests/data/workspace_sync_barrier_test.cljs @@ -10,53 +10,21 @@ component, or drop the commit. Plugin `waitForLayoutUpdate` and the composable interpreter rely on it." (:require - [app.common.files.changes-builder :as pcb] - [app.common.logic.shapes :as cls] [app.common.test-helpers.composable.comp.setups :as setup] - [app.common.test-helpers.files :as thf] - [app.common.test-helpers.ids-map :as thi] - [app.common.test-helpers.shapes :as ths] - [app.main.data.changes :as dch] [app.main.data.workspace.reflow :as wrf] [app.main.store :as st] [app.plugins.reflow :as pwrf] [cljs.test :as t :include-macros true] [frontend-tests.composable-tests.interpreter :as ftm])) -;; The watcher schedules thumbnail renders that reach `window`, absent -;; headless (see `ftm/install-thumbnail-noop!`). -(t/use-fixtures :each - {:before (fn [] - (thi/reset-idmap!) - (ftm/install-thumbnail-noop!)) - :after ftm/restore-thumbnail!}) +(t/use-fixtures :each ftm/fixture) (def ^:private red "#ff0000") -(defn- main-child-fill-commit - "A commit that sets the main child's fill to red, with `opts` merged into the - commit params." - [opts] - (let [file (ftm/current-file) - page (thf/current-page file) - changes (cls/generate-update-shapes - (pcb/empty-changes nil (:id page)) - #{(thi/id :main-child)} - #(assoc % :fills (ths/sample-fills-color :fill-color red)) - (:objects page) - {})] - (dch/commit-changes (merge {:redo-changes (:redo-changes changes) - :undo-changes (:undo-changes changes)} - opts)))) - (defn- sync-pending? [file-id] (contains? (get (wrf/pending) file-id) :sync-file)) -(defn- fill-of - [label] - (-> (ths/get-shape (ftm/current-file) label) :fills first :fill-color)) - (defn- run-commit "Install a component with a copy and emit the main child fill commit with `commit-opts`. Once the wait settles, call `check` with whether the sync @@ -65,7 +33,7 @@ [done commit-opts check] (ftm/install! (setup/simple-component-with-labeled-copy)) (let [file-id (:id (ftm/current-file))] - (st/emit! (main-child-fill-commit commit-opts)) + (st/emit! (ftm/fill-commit :main-child red commit-opts)) (let [open? (sync-pending? file-id)] (-> (pwrf/wait-for-layout-update nil 2000) (.then #(check open?) @@ -78,7 +46,7 @@ (run-commit done {} (fn [open?] (t/is open?) - (t/is (= red (fill-of :copy-child))))))) + (t/is (= red (ftm/fill-of :copy-child))))))) (t/deftest undo-commit-holds-the-wait-until-the-watcher-handles-it ;; Undo and redo commit with `save-undo? false`. The watcher only touches diff --git a/frontend/test/frontend_tests/runner.cljs b/frontend/test/frontend_tests/runner.cljs index 06bde4cb93..80c2a6b3f2 100644 --- a/frontend/test/frontend_tests/runner.cljs +++ b/frontend/test/frontend_tests/runner.cljs @@ -196,8 +196,8 @@ 'frontend-tests.data.workspace-pages-test 'frontend-tests.data.workspace-path-edition-test 'frontend-tests.data.workspace-reflow-test - 'frontend-tests.data.workspace-sync-barrier-test 'frontend-tests.data.workspace-shortcuts-test + 'frontend-tests.data.workspace-sync-barrier-test 'frontend-tests.data.workspace-texts-test 'frontend-tests.data.workspace-thumbnails-test 'frontend-tests.data.workspace-versions-test diff --git a/plugins/apps/composable-test-suite/src/composable-tests/cases/caseCopySwapSurvivesMainChanges.ts b/plugins/apps/composable-test-suite/src/composable-tests/cases/caseCopySwapSurvivesMainChanges.ts index ac8e8f8471..37d8ddc7be 100644 --- a/plugins/apps/composable-test-suite/src/composable-tests/cases/caseCopySwapSurvivesMainChanges.ts +++ b/plugins/apps/composable-test-suite/src/composable-tests/cases/caseCopySwapSurvivesMainChanges.ts @@ -1,4 +1,3 @@ -import { LibraryComponent } from "@penpot/plugin-types"; import { TestCase } from "../test-suite/TestCase.ts"; import { Situation } from "../core/Situation"; import { Color } from "../model/Color"; @@ -18,17 +17,6 @@ const RED = new Color("#ff0000"); // the component the copy swaps to const GREEN = new Color("#00ff00"); // the component the main swaps to const BLUE = new Color("#0000ff"); // remote edit -/** The main component of a nestable component's configuration. */ -function componentOf(op: OpCreateNestableComponent) { - return (s: Situation): LibraryComponent => { - const component = s.get(op.roles.mainInstance).component(); - if (component === null) { - throw new Error("the main instance has no component"); - } - return component; - }; -} - /** * Case AA — a copy's swap survives changes to the main. * @@ -63,9 +51,17 @@ export function createTestCaseCopySwapSurvivesMainChanges(): TestCase { opCreateGreen, opCreateComponent.createOpInstantiate(), opCreateComponent.createOpMakeNested(), - new OpSwap(copyNested, componentOf(opCreateRed), "the copy's nested copy for the red component"), + new OpSwap( + copyNested, + (s) => opCreateRed.getMainComponent(s), + "the copy's nested copy for the red component" + ), new OpOptional( - new OpSwap(mainNested, componentOf(opCreateGreen), "the main's nested copy for the green component") + new OpSwap( + mainNested, + (s) => opCreateGreen.getMainComponent(s), + "the main's nested copy for the green component" + ) ), new OpOptional( new OpChangeProperty( @@ -78,7 +74,7 @@ export function createTestCaseCopySwapSurvivesMainChanges(): TestCase { new OpAssert("the copy's nested copy keeps its swap", (s) => { const head = copyNested(s); Assert.that( - head.component()?.id === componentOf(opCreateRed)(s).id, + head.component()?.id === opCreateRed.getMainComponent(s).id, "the nested copy is a red instance" ); fillColor.assertEqual(fillColor.read(opCreateComponent.contentCreator.getRectangle(head)), RED); diff --git a/plugins/apps/composable-test-suite/src/composable-tests/cases/caseResetOfNestedSwapKeepsTopCopyOverrides.ts b/plugins/apps/composable-test-suite/src/composable-tests/cases/caseResetOfNestedSwapKeepsTopCopyOverrides.ts index e39a140a12..ddbd96695f 100644 --- a/plugins/apps/composable-test-suite/src/composable-tests/cases/caseResetOfNestedSwapKeepsTopCopyOverrides.ts +++ b/plugins/apps/composable-test-suite/src/composable-tests/cases/caseResetOfNestedSwapKeepsTopCopyOverrides.ts @@ -1,4 +1,3 @@ -import { LibraryComponent } from "@penpot/plugin-types"; import { TestCase } from "../test-suite/TestCase.ts"; import { Situation } from "../core/Situation"; import { Color } from "../model/Color"; @@ -21,9 +20,9 @@ const RED = new Color("#ff0000"); // the component the copy swaps to * * A copy of a component that nests another overrides its own root's opacity, * swaps its nested copy for a third component, then resets the nested copy. The - * reset undoes the swap and must change nothing outside the nested copy; today it - * also clears the root's opacity override (F12 in the stabilization plan), which - * the case pins as a known failure. + * reset undoes the swap and must change nothing outside the nested copy. It also + * clears the root's opacity override (F12 in the stabilization plan), pinned as a + * known failure. */ export function createTestCaseResetOfNestedSwapKeepsTopCopyOverrides(): TestCase { const opCreateComponent = new OpCreateNestableComponent(new ContentCreationStrategyRectangle(BASELINE)); @@ -33,13 +32,7 @@ export function createTestCaseResetOfNestedSwapKeepsTopCopyOverrides(): TestCase const { copyInstance } = opCreateComponent.roles; const copyNested = (s: Situation) => opCreateComponent.getNestedInstance(s, 1); - const redComponent = (s: Situation): LibraryComponent => { - const component = s.get(opCreateRed.roles.mainInstance).component(); - if (component === null) { - throw new Error("the red main instance has no component"); - } - return component; - }; + const redComponent = (s: Situation) => opCreateRed.getMainComponent(s); return new TestCase( "ResetOfNestedSwapKeepsTopCopyOverrides", @@ -47,8 +40,8 @@ export function createTestCaseResetOfNestedSwapKeepsTopCopyOverrides(): TestCase "another component with a red rectangle is created. A copy of the outer component " + "lowers its own opacity, swaps its nested copy for the red component, and then resets " + "the nested copy. The reset must undo the swap (the nested copy shows the original " + - "rectangle again) and leave the copy's own opacity override alone. Today the reset " + - "also clears that override (known failure F12).", + "rectangle again) and leave the copy's own opacity override alone. The reset also " + + "clears that override (known failure F12).", new OpSequence( opCreateComponent, opCreateRed, @@ -64,9 +57,9 @@ export function createTestCaseResetOfNestedSwapKeepsTopCopyOverrides(): TestCase // the reset clears the opacity, which the API then reads as null Assert.knownFailure( "F12", - opacity.read(s.get(copyInstance)) ?? null, 0.5, null, + opacity.read(s.get(copyInstance)) ?? null, (a, b) => a === b ); }) diff --git a/plugins/apps/composable-test-suite/src/composable-tests/operations/OpCreateNestableComponent.ts b/plugins/apps/composable-test-suite/src/composable-tests/operations/OpCreateNestableComponent.ts index 84d9cea450..5d3e54b25c 100644 --- a/plugins/apps/composable-test-suite/src/composable-tests/operations/OpCreateNestableComponent.ts +++ b/plugins/apps/composable-test-suite/src/composable-tests/operations/OpCreateNestableComponent.ts @@ -1,4 +1,4 @@ -import { Board, Shape } from "@penpot/plugin-types"; +import { Board, LibraryComponent, Shape } from "@penpot/plugin-types"; import { Situation } from "../core/Situation"; import { Operation } from "../core/Operation"; import { Role } from "../core/Role"; @@ -244,4 +244,16 @@ export class OpCreateNestableComponent( bug: string, - actual: T, expected: T, pinned: T, + actual: T, equals: (a: T, b: T) => boolean, render: (v: T) => string = String ): void {