github/penpot
1
0
Fork 0
mirror of https://github.com/penpot/penpot.git synced 2026-10-29 14:00:37 +00:00
Code Issues Packages Projects Releases Wiki Activity

✨ Check undo and redo of every step in the composable cases

Browse Source 
The composable cases tested undo only where a case asked for it, so a
change generator with a wrong inverse, or a step that splits into
several undo entries, went unnoticed.

Both runners now run an undo/redo round trip on every variant, unless
the case turns it off with a reason. After each user step that adds an
undo group, undo must give back the file before the step and redo the
file after it; a user step that adds no group must change nothing. At
the end of the variant, undoing back to the last assembly step and
redoing everything must give back both states. Files compare through
a shared normalizer that drops :modified-at and, on request,
:position-data, and keeps :touched and :remote-synced.

- The pure runner gets a redo stack and a Redo node; a user operation
  that pushes a group empties it. Case P undoes and redoes a main edit
  in both suites.
- The frontend interpreter runs the round trip through the real undo
  and redo events, and checks that each step moves the workspace undo
  index by one entry. Each variant starts with an empty undo stack.

A case can mark a failure that a known bug causes. The mark pins, per
phase, the signature of the failure (the shape, page and component
attributes or the undo index that differ). It covers no other failure,
and it fails the case once the bug stops happening.

The check found two bugs, both pinned:
- F41: when sync moves a copy child to an earlier position, its undo
  change puts the child back at the same index, so undoing a reorder
  in a main leaves the copies reordered (case F).
- F43: the reflow after a swap or variant switch loses the step's undo
  group, so its commits land in undo entries of their own and one undo
  leaves the step half reverted (cases L and M).
This commit is contained in:
alonso.torres 2026-10-09 13:46:11 +02:00
parent e625ad2234
commit 820cbfee38
11 changed files with 1056 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
.serena/memories/frontend/composable-component-tests.md
View File

@ -87,13 +87,15 @@ wrapper deftest in BOTH test namespaces (or only the frontend one if it needs fr
Two pure runners (no store, JVM + CLJS):
- `core/run-variant`/`run-all`: apply nodes only (no sync, `n/undo` throws). For engine tests.
- `comp.runner/run-variant`/`run-all`: the case runner. Every comp node declares its kind via
`n/IComponentOperation` (`op-kind`: `:assembly`, `:user`, `:undo`, `:frontend-only`); the
`n/IComponentOperation` (`op-kind`: `:assembly`, `:user`, `:undo`, `:redo`, `:frontend-only`); the
runner and the interpreter's `sync-op?` dispatch on it. A NEW node MUST implement it. User ops
record their production changes (`n/record-changes`, nil when nothing changed); the runner
throws if a `:user` op records nothing or another kind records changes. After a user op the
runner syncs to a fixpoint (`ch/components-changed` + `generate-sync-file-changes`, one pass
per cascade level, like the frontend watcher) and pushes op + syncs as one undo group.
`n/undo` reverts the latest group, no re-sync. The runner validates the file (against the
`n/undo` reverts the latest group and moves it to a redo stack; `n/redo` applies it again
(interpreter: `dwu/redo`); neither re-syncs. A user op that pushes a group empties the redo
stack; one that changed nothing keeps it. The runner validates the file (against the
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
@ -104,8 +106,35 @@ Two pure runners (no store, JVM + CLJS):
frontend events call. Not modelled: the `:modified-at` bump, and the swap/switch event follow-ups
(token propagation, WASM text resize, layout update). Tests:
`common-tests.logic.composable-runner-test`.
- Undo/redo round trip (`comp/undo_check.cljc`, alias `uc`), on by default in the pure runner
(`:undo-check?`): after each `:user` step that pushed a group, undo must give back the
normalized file before it and redo the file after it (the variant continues from the redone
file); a user step that pushed nothing must change nothing (`:no-undo-entry`); at the end,
undo back to the last assembly step (the baseline; a case's own undo below it moves it) and
redo all. Files compare through `app.common.test-helpers.normalize` (`thn/normalize-file`:
drops file/component `:modified-at`, optionally `:position-data`; shapes as plain maps).
Failures are recorded in the situation with labelled diffs (labels die with the variant, so
they are resolved when recorded) and a `:signature`, the set of what differs
(`uc/signature`: `[:object <label> attr]`, `:missing`/`:extra`, `:page`/`:component` alike,
`[:undo-index n]`, `[:error]`; unlabelled shapes are `:unlabelled`); `uc/check!` asserts after
the asserter and prints the signature. A case map's `:undo-check` takes `{:off "reason"}` or
`{:known-failures [{:bug "F41" :fails {phase signature} :op <the case's node> :runners
#{:pure :frontend} :when pred}]}`: strict expected failures. A mark applies to variants of its
runners (`uc/with-runner`) where its `:op` ran and `:when` holds; it covers a failure only
when the signature is exactly the pinned one, and a pinned phase that does not fail as pinned
fails the case. Marks without `:fails` throw. Never edit a pin to make a case pass: a pin
changes only when the failure is understood, and the mark goes only in the fix commit. The interpreter runs the same round trip on every `:user` and
`:frontend-only` event step through the real `dwu/undo`/`dwu/redo`, and also checks the
workspace undo index (`:undo-index`/`:redo-index` phases): a step must add exactly one undo
entry or group. File installs (assembly ops, reset) are its baselines. The interpreter
empties `:workspace-undo` per variant. Frontend snapshots drop `:position-data` under WASM.
Undo groups get lost in derived work: `initialize-shape-layout` buffers `:layout/update`
without its `:undo-group` (F43), so a swap's reflow lands in entries of its own. Match
steps by node identity, never by record type or rendered name: `n/MoveChild` does not resolve
through an alias on the JVM, and the JS test build strips record names (transcripts show
`node`).
- Label map gotcha: running a second variant re-registers labels, so assert on a situation
before running the next one (`thi/id` then points at the new run's shapes). Case letters B..O;
before running the next one (`thi/id` then points at the new run's shapes). Case letters B..P;
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) are the flagship pattern — read them before

180
common/src/app/common/test_helpers/composable/comp/cases.cljc
View File

@ -27,6 +27,7 @@
H — locality: a library main's change reaches the consuming file's copy on
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.
L — the swap sweep: swaps at any subset of nesting levels.
@ -122,23 +123,28 @@
"Case F."
[]
(let [move (n/move-child :main-child1 :main-root 2)]
{:setup setup/component-with-many-children
:operation (tm/in-sequence [move])
:asserter (fn [situation]
(let [copy-root (setup/copy-root situation)
order (vec (:shapes copy-root))
c1 (setup/copy-child situation 1)
c2 (setup/copy-child situation 2)
c3 (setup/copy-child situation 3)]
(t/is (= (nth order 0) (:id c2)))
(t/is (= (nth order 1) (:id c1)))
(t/is (= (nth order 2) (:id c3)))
(t/is (some? (:shape-ref c1)))
(t/is (some? (:shape-ref c2)))
(t/is (some? (:shape-ref c3)))
(t/is (nil? (:touched c1)))
(t/is (nil? (:touched c2)))
(t/is (nil? (:touched c3)))))}))
{:setup setup/component-with-many-children
:operation (tm/in-sequence [move])
;; the undo of the sync's move leaves the copy children reordered
:undo-check {:known-failures [{:bug "F41"
:fails {:undo #{[:object :copy-root :shapes]}
:variant-undo #{[:object :copy-root :shapes]}}
:op move}]}
:asserter (fn [situation]
(let [copy-root (setup/copy-root situation)
order (vec (:shapes copy-root))
c1 (setup/copy-child situation 1)
c2 (setup/copy-child situation 2)
c3 (setup/copy-child situation 3)]
(t/is (= (nth order 0) (:id c2)))
(t/is (= (nth order 1) (:id c1)))
(t/is (= (nth order 2) (:id c3)))
(t/is (some? (:shape-ref c1)))
(t/is (some? (:shape-ref c2)))
(t/is (some? (:shape-ref c3)))
(t/is (nil? (:touched c1)))
(t/is (nil? (:touched c2)))
(t/is (nil? (:touched c3)))))}))
(defn undo-reverts-edit-and-its-propagation
"Case I. Change the main (which propagates to the clean copy), then undo. A
@ -160,6 +166,21 @@
;; … leaving the copy clean.
(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)]
{: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 (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,
@ -232,6 +253,57 @@
(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 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
@ -250,20 +322,21 @@
(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
: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)))))]))}))
{: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)))))]))}))
(defn variant-switch-scenarios
"Case M. VARIANT-SWITCH SWEEP — the variant-switch flavour of case L. Build
@ -291,28 +364,29 @@
(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
: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)))))]))}))
{: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)))))]))}))
(defn variant-switch-keeps-override-only-where-mains-agree
"Case O. A copy overrides the fill of its nested variant's rect, then the

30
common/src/app/common/test_helpers/composable/comp/nodes.cljc
View File

@ -56,6 +56,8 @@
;; 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
@ -64,7 +66,8 @@
(defprotocol IComponentOperation
(op-kind [op]
"How a runner treats `op`: :assembly, :user, :undo or :frontend-only."))
"How a runner treats `op`: :assembly, :user, :undo, :redo or
:frontend-only."))
(defn record-changes
"Store `changes`, the production changes a user operation applied (nil when
@ -1076,6 +1079,31 @@
[]
(tm/assign-id (->Undo)))
;; ---------------------------------------------------------------------------
;; 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.
;; ---------------------------------------------------------------------------
(defrecord Redo []
IComponentOperation
(op-kind [_] :redo)
tm/IOperation
(apply-to [_ _]
(throw (ex-info (str "Redo has no `apply-to` realisation: it needs a redo stack. "
"Run it through the pure runner (comp.runner) or the frontend "
"interpreter.")
{: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)."
[]
(tm/assign-id (->Redo)))
;; ---------------------------------------------------------------------------
;; add-child — add a new shape into a (main) component, structurally

209
common/src/app/common/test_helpers/composable/comp/runner.cljc
View File

@ -14,13 +14,18 @@
`ch/components-changed` reports, then the components each sync changed,
until none is left. The frontend component watcher does the same, one
pass per sync commit.
- Undo. A user operation and the syncs it caused form one undo group.
`n/undo` reverts the latest group and syncs nothing, as in the frontend,
where an undo commit only bumps the component's `:modified-at`.
- Undo and redo. A user operation and the syncs it caused form one undo
group. `n/undo` reverts the latest group and `n/redo` applies again the
latest reverted one; neither syncs, as in the frontend, where an undo
or redo commit only bumps the component's `:modified-at`. A user
operation that pushes a group empties the redo stack.
Assembly operations (create, instantiate, nest) change the file with no sync
and no undo group, like the frontend interpreter's file installs.
Every variant also runs the undo/redo round trip of
`app.common.test-helpers.composable.comp.undo-check`.
Operations whose result needs frontend code (kind `:frontend-only`) are
rejected. Not modelled: the `:modified-at` bump of a changed component,
and the frontend follow-ups of a swap or switch (token propagation, WASM
@ -30,6 +35,7 @@
[app.common.files.changes-builder :as pcb]
[app.common.logic.libraries :as cll]
[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 thf]))
@ -109,30 +115,67 @@
(defn- push-undo-group
"Add `group`, the changes of one user operation and its syncs in order, to
the undo stack. Changes with nothing to undo are left out, as the frontend
undo stack leaves out commits with no undo changes."
the undo stack and empty the redo stack. Changes with nothing to undo are
left out, as the frontend undo stack leaves out commits with no undo
changes; a group left empty changes neither stack."
[situation group]
(let [group (filterv (comp seq :undo-changes) group)]
(cond-> situation
(seq group) (update ::undo-stack (fnil conj []) group))))
(seq group) (-> (update ::undo-stack (fnil conj []) group)
(assoc ::redo-stack [])))))
(defn- run-undo
"Revert the latest undo group, newest changes first, and validate the
result. With an empty stack it changes nothing, like the frontend undo."
[situation op]
(let [stack (get situation ::undo-stack [])
group (peek stack)
file (reduce (fn [file changes]
(thf/apply-changes file
{:redo-changes (:undo-changes changes)}
:validate? false))
(tm/file situation)
(rseq (or group [])))]
(defn- apply-group
"Apply to the situation's file the `side` changes (`:undo-changes` or
`:redo-changes`) of each changes in `group`, in order, and validate the
result."
[situation side group]
(let [file (reduce (fn [file changes]
(thf/apply-changes file
{:redo-changes (get changes side)}
:validate? false))
(tm/file situation)
group)]
(-> situation
(tm/with-file file)
(validate-settled!)
(assoc ::undo-stack (if (seq stack) (pop stack) stack))
(tm/record-application op {:undone (count group)}))))
(validate-settled!))))
(defn- move-group
"Move the latest group of the `from` stack to the `to` stack, applying its
`side` changes, in `order` (`seq` or `rseq`). Returns `[situation group]`;
with an empty `from` stack it changes nothing, like the frontend undo and
redo."
[situation from to side order]
(let [stack (get situation from [])]
(if (empty? stack)
[situation nil]
(let [group (peek stack)]
[(-> situation
(apply-group side (order group))
(assoc from (pop stack))
(update to (fnil conj []) group))
group]))))
(defn- undo-group
"Revert the latest undo group, newest changes first, and move it to the
redo stack."
[situation]
(move-group situation ::undo-stack ::redo-stack :undo-changes rseq))
(defn- redo-group
"Apply again the latest redo group, oldest changes first, and move it back
to the undo stack."
[situation]
(move-group situation ::redo-stack ::undo-stack :redo-changes seq))
(defn- run-undo
[situation op]
(let [[situation group] (undo-group situation)]
(tm/record-application situation op {:undone (count group)})))
(defn- run-redo
[situation op]
(let [[situation group] (redo-group situation)]
(tm/record-application situation op {:redone (count group)})))
(defn- op-kind
"The kind of a leaf operation (see `n/IComponentOperation`), or nil for an
@ -159,19 +202,89 @@
:op op
:kind kind}))))
(defn undo-depth
"How many undo groups the runner holds in `situation`."
[situation]
(count (get situation ::undo-stack)))
(defn redo-depth
"How many redo groups the runner holds in `situation`."
[situation]
(count (get situation ::redo-stack)))
(defn- snapshot
[situation]
(uc/snapshot (tm/file situation)))
(defn- try-round-trip
"Run `round-trip` (situation -> situation) on `situation`. When it throws,
record the error as a failure of `phase` at `step` and return `situation`
unchanged."
[situation step phase round-trip]
(try
(round-trip situation)
(catch #?(:clj Exception :cljs :default) e
(uc/add-error situation step phase (str (ex-message e) " " (pr-str (ex-data e)))))))
(defn- check-step
"The round trip of user step `op` (see `uc`): `before` is the normalized
file before it and `depth` the undo depth before it."
[situation op before depth]
(let [step (uc/step situation op)
after (snapshot situation)]
(if (= depth (undo-depth situation))
(uc/compare-states situation step :no-undo-entry before after)
(try-round-trip
situation step :undo
(fn [situation]
(let [undone (first (undo-group situation))
undone (uc/compare-states undone step :undo before (snapshot undone))
redone (first (redo-group undone))]
(uc/compare-states redone step :redo after (snapshot redone))))))))
(defn- check-variant
"The end-of-variant round trip (see `uc`): undo back to the baseline, then
redo all."
[situation]
(let [{:keys [depth] :as baseline} (uc/baseline situation)
times (- (undo-depth situation) depth)
final (snapshot situation)]
(if (pos? times)
(try-round-trip
situation nil :variant-undo
(fn [situation]
(let [undone (nth (iterate (comp first undo-group) situation) times)
undone (uc/compare-states undone nil :variant-undo
(:snapshot baseline) (snapshot undone))
redone (nth (iterate (comp first redo-group) undone) times)]
(uc/compare-states redone nil :variant-redo final (snapshot redone)))))
situation)))
(defn- mark-baseline
[situation]
(uc/mark-baseline situation (undo-depth situation) (snapshot situation)))
(defn- run-node
"Apply one leaf operation of `kind`. A user operation is followed by its sync
(when `:sync?`) and pushes its undo group."
[situation op kind {:keys [sync?]}]
(when `:sync?`), pushes its undo group, and gets its round trip (when
`:undo-check?`). An assembly operation moves the round trip's baseline."
[situation op kind {:keys [sync? undo-check?]}]
(let [old-data (:data (tm/file situation))
before (when undo-check? (snapshot situation))
depth (undo-depth situation)
[recorded? changes situation] (n/take-changes (tm/apply-to op situation))]
(check-recorded-changes! op kind recorded?)
(if (nil? changes)
situation
(let [[situation syncs] (if sync?
(sync-file situation old-data changes)
[situation []])]
(push-undo-group situation (into [changes] syncs))))))
(cond-> (if (nil? changes)
situation
(let [[situation syncs] (if sync?
(sync-file situation old-data changes)
[situation []])]
(push-undo-group situation (into [changes] syncs))))
(and undo-check? (= kind :user))
(check-step op before depth)
(and undo-check? (= kind :assembly))
(mark-baseline))))
(defn- run-op
[situation op opts]
@ -187,7 +300,15 @@
(let [kind (op-kind op)]
(case kind
:undo
(run-undo situation op)
(let [situation (run-undo situation op)]
;; never undo past the state a case's own undo went back to
(cond-> situation
(and (:undo-check? opts)
(< (undo-depth situation) (:depth (uc/baseline situation))))
(mark-baseline)))
:redo
(run-redo situation op)
:frontend-only
(throw (ex-info (str "The pure runner cannot run " (pr-str (type op))
@ -198,19 +319,27 @@
(run-node situation op kind opts)))))
(defn undo-depth
"How many undo groups the runner holds in `situation`."
[situation]
(count (get situation ::undo-stack)))
(defn run-variant
"Run one concrete (already enumerated) variant: build a fresh situation with
`setup` and run `operation` with sync and undo, returning the resulting
situation. Options: `:sync?` (default true) syncs after each user
operation."
situation. Options:
- `:sync?` (default true) syncs after each user operation;
- `:undo-check?` (default true, false when the case map turns the check
off) runs the undo/redo round trip of
`app.common.test-helpers.composable.comp.undo-check`; its failures are
recorded in the situation for `uc/check!`."
([case-map] (run-variant case-map {}))
([{:keys [setup operation]} opts]
(run-op (setup) operation (merge default-opts opts))))
([{:keys [setup operation] :as case-map} opts]
(let [opts (merge default-opts
{:undo-check? (uc/enabled? case-map)}
opts)]
(if (:undo-check? opts)
(-> (setup)
(uc/with-runner :pure)
(mark-baseline)
(run-op operation opts)
(check-variant))
(run-op (setup) operation opts)))))
(defn run-all
"Enumerate `operation` into its concrete variants and run each with
@ -218,4 +347,4 @@
resulting situations in enumeration order."
([case-map] (run-all case-map {}))
([case-map opts]
(tm/run-all case-map #(run-variant % opts))))
(tm/run-all case-map #(run-variant (merge case-map %) opts))))

241
common/src/app/common/test_helpers/composable/comp/undo_check.cljc Normal file
View File

@ -0,0 +1,241 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.common.test-helpers.composable.comp.undo-check
"The undo/redo round trip that both composable runners run on every case
variant. With S(k) the normalized file after step k:
- after a user step k that adds an undo entry, undo must give back
S(k-1) and redo S(k); the variant then goes on from the redone file;
- a user step that adds no undo entry must change nothing;
- at the end of the variant, undoing back to the last assembly step must
give back the file after it, and redoing all again the final file.
Assembly steps do not go through the undo stack, so the check never undoes
past the last one. Inline `Test` operations are not run again.
The runners record each failed check in the situation, with its
`:signature`, the set of what differs (see `signature`), and `check!`
asserts on them after the case's own asserter. The case map's
`:undo-check` may hold:
- `:off`, the reason the case turns the check off;
- `:known-failures`, the failures a known bug causes: strict expected
failures that pin how the check fails. Each is a map of `:bug` (its
row in the plan's suspected bugs), `:fails` (phase -> the exact
signature the failure of that phase has), `:op` (the case's operation
node whose step fails, matched by node identity; any step when nil),
`:runners` (a subset of `#{:pure :frontend}`; both when nil) and
`:when` (a situation predicate).
A mark applies to a variant of its runners where its `:op` ran and
`:when` holds. A failure it does not pin exactly stays a failure, and
a pinned phase that does not fail fails the case, so the mark goes
only with the fix."
(:require
[app.common.test-helpers.composable.core :as tm]
[app.common.test-helpers.ids-map :as thi]
[app.common.test-helpers.normalize :as thn]
[clojure.test :as t]
[clojure.walk :as walk]))
(defn with-runner
"Record in `situation` which runner runs it, `:pure` or `:frontend`, for
the `:runners` of known failures."
[situation runner]
(assoc situation ::runner runner))
(defn enabled?
"Whether `case-map` runs the round trip."
[case-map]
(not (contains? (:undo-check case-map) :off)))
(defn snapshot
"The normalized value of `file` that the round trip compares."
([file] (snapshot file {}))
([file opts] (thn/normalize-file file opts)))
(defn mark-baseline
"Record the state the end-of-variant round trip undoes back to: the
normalized file `snap` with `depth` undo groups on the stack."
[situation depth snap]
(assoc situation ::baseline {:depth depth :snapshot snap}))
(defn baseline
"The state recorded by `mark-baseline`, as `{:depth :snapshot}`."
[situation]
(::baseline situation))
(defn step
"The step of operation `op` in `situation`, as failures name it: the node
`:id` and its `:description` in the transcript."
[situation op]
{:id (tm/node-id op)
:description (tm/describe-application situation op)})
(defn- add-failure
[situation failure]
(update situation ::failures (fnil conj []) failure))
(defn add-error
"Record that the round trip could not run `phase` at `step` (see `step`;
nil for the end-of-variant phases): `error` says why."
[situation step phase error]
(add-failure situation {:phase phase
:step step
:signature #{[:error]}
:error error}))
(defn- labelled
"`value` with every uuid replaced by its test label. Labels are valid only
while the variant that registered them runs."
[value]
(walk/postwalk #(if (uuid? %) (thi/label %) %) value))
(defn- label-of
"The test label of `id`, or `:unlabelled`, so a signature is the same in
every run."
[id]
(let [label (thi/label id)]
(if (keyword? label) label :unlabelled)))
(defn- differing-keys
"The keys, other than those in `skip`, whose values differ between the maps
`expected` and `actual`."
[expected actual skip]
(->> (into (set (keys expected)) (keys actual))
(remove skip)
(filter #(not= (get expected %) (get actual %)))))
(defn- entities-signature
"What differs between the maps of entities by id `expected` and `actual`:
`[kind label attr]` for an attribute, `[kind label :missing]` or
`[kind label :extra]` for an entity on one side only. `inner` gives the
entries of what differs inside an entity present on both sides, for the
attributes it skips."
[kind expected actual skip inner]
(into #{}
(mapcat (fn [id]
(let [e (get expected id)
a (get actual id)
label (label-of id)]
(cond
(= e a) nil
(nil? a) [[kind label :missing]]
(nil? e) [[kind label :extra]]
:else (concat (for [attr (differing-keys e a skip)]
[kind label attr])
(inner e a))))))
(into (set (keys expected)) (keys actual))))
(defn signature
"What differs between the normalized files `expected` and `actual`, as a
set of entries: `[:object label attr]` for a shape attribute (or `:missing`
/ `:extra` for a whole shape), the same with `:page` and `:component`, and
`[:data key]` / `[:file key]` for anything else. Shapes without a test
label are `:unlabelled`."
[expected actual]
(let [ed (:data expected)
ad (:data actual)]
(-> #{}
(into (map #(vector :file %)) (differing-keys expected actual #{:data}))
(into (map #(vector :data %)) (differing-keys ed ad #{:pages-index :components}))
(into (entities-signature :page (:pages-index ed) (:pages-index ad) #{:objects}
(fn [e a]
(entities-signature :object (:objects e) (:objects a)
#{} (constantly nil)))))
(into (entities-signature :component (:components ed) (:components ad)
#{} (constantly nil))))))
(defn compare-states
"Record a failure of `phase` at `step` unless the normalized files
`expected` and `actual` are equal. Phases: `:undo`, `:redo`,
`:no-undo-entry` (a step that added no entry changed the file),
`:variant-undo` and `:variant-redo`."
[situation step phase expected actual]
(if (= expected actual)
situation
(add-failure situation {:phase phase
:step step
:signature (signature expected actual)
:diff (labelled (thn/diff expected actual))})))
(defn compare-index
"Record a failure of `phase` at `step` unless the workspace undo index is
`expected`: its signature is `#{[:undo-index n]}`, with `n` the entries
the index is off by. Phases: `:undo-index` and `:redo-index`."
[situation step phase expected actual]
(if (= expected actual)
situation
(add-failure situation {:phase phase
:step step
:signature #{[:undo-index (- actual expected)]}
:error (str "undo index " actual ", expected " expected)})))
(defn failures
"The failed checks recorded in `situation`, in order."
[situation]
(get situation ::failures []))
(defn- matches?
"Whether the known failure `mark` pins `failure` exactly."
[{:keys [fails op]} failure]
(and (= (get fails (:phase failure)) (:signature failure))
(or (nil? op)
(nil? (:step failure))
(= (tm/node-id op) (get-in failure [:step :id])))))
(defn- check-mark!
[{:keys [bug fails] :as mark}]
(when-not (and (map? fails) (seq fails))
(throw (ex-info (str "Known undo failure " bug " pins no failure: give it "
"`:fails`, phase -> signature")
{:type ::unpinned-mark
:mark mark}))))
(defn verdict
"The failures of `situation`, a variant of `case-map`, that no known failure
of the case pins (`:unexpected`), and the pinned phases of the known
failures that apply to the variant but did not fail as pinned
(`:resolved`, each the mark with its `:phase`)."
[situation case-map]
(let [marks (get-in case-map [:undo-check :known-failures])
_ (run! check-mark! marks)
applies? (fn [{:keys [op runners] pred :when}]
(and (or (nil? runners) (contains? runners (::runner situation)))
(or (nil? op) (tm/applied? situation op))
(or (nil? pred) (pred situation))))
known (filter applies? marks)
found (failures situation)]
{:unexpected (filterv (fn [failure] (not-any? #(matches? % failure) known)) found)
:resolved (vec (for [mark known
phase (keys (:fails mark))
:when (not-any? #(and (= phase (:phase %)) (matches? mark %))
found)]
(assoc mark :phase phase)))}))
(defn- describe-failure
[{:keys [phase step signature diff error]}]
(str "Undo check failed: " (name phase)
(when step (str " of step " (:description step)))
"\n signature: " (pr-str signature)
(if error
(str "\n error: " error)
(str "\n expected only: " (pr-str (first diff))
"\n actual only: " (pr-str (second diff))))))
(defn check!
"Assert that the round trip of `situation`, a variant of `case-map`, found
no failure but the case's known ones, and that each known one happened."
[situation case-map]
(when (enabled? case-map)
(let [{:keys [unexpected resolved]} (verdict situation case-map)]
(doseq [failure unexpected]
(t/is false (describe-failure failure)))
(doseq [{:keys [bug phase fails op]} resolved]
(t/is false (str "Known undo failure " bug " did not fail as pinned: "
(name phase) " " (pr-str (get fails phase))
(when op (str " of step " (pr-str (dissoc (into {} op) ::tm/id))))
". If the fix landed, remove the mark in the fix commit; "
"otherwise the failure changed: see the failures above"))))))

6
common/src/app/common/test_helpers/composable/core.cljc
View File

@ -186,6 +186,12 @@
args (dissoc record ::kind)]
(str kind (when (seq args) (str " " (pr-str args))))))
(defn describe-application
"A one-line description of what `node` recorded about its application in
`situation` (see `describe-applied`), or nil if it has not been applied."
[situation node]
(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

70
common/src/app/common/test_helpers/normalize.cljc Normal file
View File

@ -0,0 +1,70 @@
;; This Source Code Form is subject to the terms of the Mozilla Public
;; License, v. 2.0. If a copy of the MPL was not distributed with this
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
;;
;; Copyright (c) KALEIDOS SUBSIDIARY SL
(ns app.common.test-helpers.normalize
"Normalized file values, to compare two states of a file in tests (the
undo/redo round trip of the composable runners, the golden master).
Normalizing drops only what legitimately differs between two states that
are the same for the user:
- `:modified-at` of the file and of each component, bumped by every
change, undo and redo included;
- with `{:position-data? false}`, the shapes' `:position-data`, the text
layout that WASM measurement regenerates.
Shapes and the maps that hold them become plain maps, so a shape record
compares equal to a map with the same attributes, and an objects map (see
`app.common.types.objects-map`) to a plain map with the same entries.
Everything else is kept, `:touched` and `:remote-synced` included."
(:require
[app.common.data :as d]
[clojure.data :as data]))
(defn- map-vals
"A plain map with `f` applied to each value of the map `m`, whatever its
type."
[f m]
(into {} (map (fn [[k v]] [k (f v)])) m))
(defn- normalize-shape
[shape {:keys [position-data?]}]
(cond-> (into {} shape)
(not position-data?) (dissoc :position-data)))
(defn- normalize-objects
[objects opts]
(map-vals #(normalize-shape % opts) objects))
(defn- normalize-page
[page opts]
(d/update-when page :objects normalize-objects opts))
(defn- normalize-component
[component opts]
(-> component
(dissoc :modified-at)
(d/update-when :objects normalize-objects opts)))
(defn normalize-file
"The normalized value of `file` (see the namespace doc). Options:
`:position-data?` (default true) keeps the shapes' `:position-data`."
([file] (normalize-file file {}))
([file opts]
(let [opts (merge {:position-data? true} opts)]
(-> file
(dissoc :modified-at)
(update :data
(fn [data]
(-> data
(d/update-when :pages-index
(partial map-vals #(normalize-page % opts)))
(d/update-when :components
(partial map-vals #(normalize-component % opts))))))))))
(defn diff
"What differs between the values `a` and `b`, as `[only-in-a only-in-b]`
(see `clojure.data/diff`)."
[a b]
(vec (take 2 (data/diff a b))))

200
common/test/common_tests/logic/composable_runner_test.cljc
View File

@ -11,6 +11,7 @@
[app.common.test-helpers.composable.comp.nodes :as n]
[app.common.test-helpers.composable.comp.runner :as r]
[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]
@ -120,6 +121,64 @@
(t/is (contains? (:touched copy-rect) :fill-group))
(t/is (= 1 (r/undo-depth situation)))))
(t/deftest redo-reapplies-edit-and-its-sync
(let [situation (r/run-variant
{:setup setup/simple-component-with-labeled-copy
:operation (tm/in-sequence
[(n/change-property :main-child :fills red)
(n/undo)
(n/redo)])})
copy (setup/copy-instance situation)]
(t/is (= red (fill-of (setup/main-instance situation))))
(t/is (= red (fill-of copy)))
(t/is (nil? (:touched copy)))
(t/is (= 1 (r/undo-depth situation)))
(t/is (zero? (r/redo-depth situation)))))
(t/deftest redo-reapplies-groups-in-undo-order
(let [situation (r/run-variant
{:setup setup/simple-component-with-labeled-copy
:operation (tm/in-sequence
[(n/change-property :main-child :fills red)
(n/change-property :main-child :fills green)
(n/undo)
(n/undo)
(n/redo)])})]
(t/is (= red (fill-of (setup/copy-instance situation))))
(t/is (= 1 (r/undo-depth situation)))
(t/is (= 1 (r/redo-depth situation)))))
(t/deftest user-operation-empties-the-redo-stack
(let [situation (r/run-variant
{:setup setup/simple-component-with-labeled-copy
:operation (tm/in-sequence
[(n/change-property :main-child :fills red)
(n/undo)
(n/change-property :main-child :fills green)
(n/redo)])})]
(t/is (= green (fill-of (setup/copy-instance situation))))
(t/is (= 1 (r/undo-depth situation)))
(t/is (zero? (r/redo-depth situation)))))
(t/deftest unchanged-user-operation-keeps-the-redo-stack
(let [situation (r/run-variant
{:setup setup/simple-component-with-labeled-copy
:operation (tm/in-sequence
[(n/change-property :main-child :fills red)
(n/undo)
(n/change-property :main-child :fills original)
(n/redo)])})]
(t/is (= red (fill-of (setup/copy-instance situation))))))
(t/deftest redo-with-an-empty-stack-changes-nothing
(let [situation (r/run-variant
{:setup setup/simple-component-with-labeled-copy
:operation (tm/in-sequence
[(n/change-property :main-child :fills red)
(n/redo)])})]
(t/is (= red (fill-of (setup/copy-instance situation))))
(t/is (= 1 (r/undo-depth situation)))))
(t/deftest assembly-operations-push-no-undo-group
(let [m "main"
situation (r/run-variant
@ -260,3 +319,144 @@
(n/switch-variant (n/nested-head-of m 0) "a")])})]
(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.
(defrecord WrongUndoEdit []
n/IComponentOperation
(op-kind [_] :user)
tm/IOperation
(apply-to [this situation]
(let [file (tm/file situation)
page (thf/current-page file)
changes (cls/generate-update-shapes (pcb/empty-changes nil (:id page))
#{(:id (setup/copy-root situation))}
#(assoc % :opacity 0.5)
(:objects page)
{})
changes (update changes :undo-changes
(partial mapv #(cond-> %
(= :mod-obj (:type %))
(update :operations conj {:type :set
:attr :name
:val "Wrong"
:ignore-touched true
:ignore-geometry false}))))]
(-> situation
(tm/with-file (thf/apply-changes file changes))
(n/record-changes changes)
(tm/record-application this {})))))
;; A user operation that changes the file with no undo changes.
(defrecord UndoableEdit []
n/IComponentOperation
(op-kind [_] :user)
tm/IOperation
(apply-to [this situation]
(let [file (tm/file situation)
page (thf/current-page file)
changes (-> (cls/generate-update-shapes (pcb/empty-changes nil (:id page))
#{(:id (setup/copy-root situation))}
#(assoc % :opacity 0.5)
(:objects page)
{})
(assoc :undo-changes []))]
(-> situation
(tm/with-file (thf/apply-changes file changes))
(n/record-changes changes)
(tm/record-application this {})))))
(defn- phases
[situation]
(mapv :phase (uc/failures situation)))
(t/deftest round-trip-passes-for-exact-inverses
(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)
(n/undo)
(n/redo)])})]
(t/is (empty? (uc/failures situation)))
(t/is (= red (fill-of (setup/main-instance situation))))))
(t/deftest round-trip-reports-a-wrong-undo
(let [situation (r/run-variant {:setup setup/simple-component-with-copy
: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 (= {: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)})]
(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)
:undo-check {:off "testing the switch"}})]
(t/is (empty? (uc/failures situation)))))
(t/deftest round-trip-never-undoes-past-an-assembly-step
;; The edit before the copy exists is not undone at the end of the variant,
;; so the main keeps it.
(let [m "main"
situation (r/run-variant
{:setup setup/empty-situation
:operation (tm/in-sequence
[(n/create-component m original)
(n/change-property (n/main-rect-of m) :fills red)
(n/instantiate-copy m)
(n/change-property (n/copy-rect-of m) :fills green)])})]
(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"}
page-id (thi/new-id! :page)
file (fn [objects] {:data {:pages-index {page-id {:id page-id :objects objects}}}})]
(t/is (= #{[:object :shape :opacity] [:object :other :extra]}
(uc/signature (file {(:id shape) shape})
(file {(:id shape) (assoc shape :opacity 0.5)
(:id other) other}))))
(t/is (= #{[:object :unlabelled :missing]}
(uc/signature (file {(uuid/next) shape}) (file {}))))))
(t/deftest known-failures-pin-how-the-check-fails
(let [edit (tm/assign-id (->WrongUndoEdit))
situation (r/run-variant {:setup setup/simple-component-with-copy
:operation edit})
pin #{[:object :copy-root :name]}
known {:bug "F0" :fails {:undo pin :redo pin :variant-undo pin} :op edit}
verdict #(uc/verdict situation {:undo-check {:known-failures %}})]
(t/is (= {:unexpected [] :resolved []} (verdict [known])))
(t/is (= [:undo :redo :variant-undo]
(mapv :phase (:unexpected (uc/verdict situation {})))))
(t/testing "a failure that differs from its pin stays a failure"
(let [{:keys [unexpected resolved]}
(verdict [(assoc-in known [:fails :undo] #{[:object :copy-root :opacity]})])]
(t/is (= [:undo] (mapv :phase unexpected)))
(t/is (= [:undo] (mapv :phase resolved)))))
(t/testing "a pinned phase that does not fail is resolved"
(t/is (= [:variant-redo]
(mapv :phase (:resolved (verdict [(assoc-in known [:fails :variant-redo] pin)]))))))
(t/testing "a mark applies only where its step ran and its runner runs"
(t/is (= [] (:resolved (verdict [known (assoc known :op (tm/assign-id (->WrongUndoEdit)))]))))
(t/is (= [] (:resolved (verdict [known (assoc known :runners #{:frontend} :op nil)])))))
(t/testing "a mark must pin its failures"
(t/is (thrown? #?(:clj Exception :cljs :default)
(verdict [(dissoc known :fails)]))))))

14
common/test/common_tests/logic/composable_sync_test.cljc
View File

@ -11,6 +11,7 @@
(:require
[app.common.test-helpers.composable.comp.cases :as cases]
[app.common.test-helpers.composable.comp.runner :as r]
[app.common.test-helpers.composable.comp.undo-check :as uc]
[app.common.test-helpers.composable.core :as tm]
[app.common.test-helpers.ids-map :as thi]
[clojure.test :as t]))
@ -18,12 +19,14 @@
(t/use-fixtures :each thi/test-fixture)
(defn- check
"Run every variant of `case-map` and apply its asserter to each result."
"Run every variant of `case-map`, apply its asserter to each result and
assert that its undo/redo round trip passed."
[{:keys [asserter] :as case-map}]
(doseq [situation (r/run-all case-map)]
(when asserter
(t/testing (str "operations:\n " (tm/describe-applied situation))
(asserter situation)))))
(t/testing (str "operations:\n " (tm/describe-applied situation))
(when asserter
(asserter situation))
(uc/check! situation case-map))))
(t/deftest case-b-copy-override-survives-later-main-change
(check (cases/copy-override-survives-later-main-change)))
@ -46,6 +49,9 @@
(t/deftest case-i-undo-reverts-edit-and-its-propagation
(check (cases/undo-reverts-edit-and-its-propagation)))
(t/deftest case-p-redo-reapplies-edit-and-its-propagation
(check (cases/redo-reapplies-edit-and-its-propagation)))
(t/deftest case-k-synchronisation-scenarios
(check (cases/synchronisation-scenarios)))

3
frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs
View File

@ -45,6 +45,9 @@
(t/deftest case-i-undo-reverts-edit-and-its-auto-propagation
(t/async done (ftm/check done (cases/undo-reverts-edit-and-its-propagation))))
(t/deftest case-p-redo-reapplies-edit-and-its-auto-propagation
(t/async done (ftm/check done (cases/redo-reapplies-edit-and-its-propagation))))
(t/deftest case-h-library-change-propagates-across-file-boundary-on-sync
(t/async done (ftm/check done (cases/library-change-propagates-across-file-boundary-on-sync))))

181
frontend/test/frontend_tests/composable_tests/interpreter.cljs
View File

@ -40,6 +40,7 @@
from `st/state`. State is re-installed per variant for isolation."
(:require
[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]
@ -52,6 +53,7 @@
[app.main.data.workspace.transforms :as dwt]
[app.main.data.workspace.undo :as dwu]
[app.main.data.workspace.variants :as dwv]
[app.main.features :as features]
[app.main.repo :as rp]
[app.main.store :as st]
[app.plugins.reflow :as pwrf]
@ -136,6 +138,7 @@
RemoveChild -> delete-shapes (generate-delete-shapes)
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)
(In-file propagation is automatic — the watcher — so no propagate op exists.)"
[op situation]
(cond
@ -210,6 +213,10 @@
;; undo stack was maintained automatically by the prior ops' commits.
[dwu/undo]
(instance? n/Redo op)
;; Apply again the latest undone operation(s) via the real redo event.
[dwu/redo]
:else
(throw (ex-info (str "op->events: no frontend realisation for " (pr-str (type op)))
{:op op}))))
@ -226,7 +233,8 @@
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."
linked libraries. The undo stack starts empty, so an undo never reaches the
previous variant's entries."
[situation]
(let [file (tm/file situation)
aux (tm/aux-files situation)]
@ -237,6 +245,7 @@
:current-file-id (:id file)
:current-page-id (cthf/current-page-id file)
:permissions {:can-edit true}
:workspace-undo {}
:files (into {(:id file) file}
(map (fn [[lib-id lib]] [lib-id (assoc lib :library-of (:id file))]))
aux))))))
@ -301,6 +310,113 @@
:current-page-id (cthf/current-page-id file))
(assoc-in [:files (:id file)] file)))))
(defn- unwrap
"The concrete operation of an op unit (the chosen op of a RecordedChoice)."
[op]
(if (tm/recorded-choice? op) (tm/choice-of op) op))
;; --------------------------------------------------------------------------
;; 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.
;; --------------------------------------------------------------------------
(defn- undo-index
"The workspace undo index: the entry the next undo reverts, -1 when none."
[]
(let [{:keys [index items]} (:workspace-undo @st/state)]
(or index (dec (count items)))))
(defn- snapshot
"The normalized live file the round trip compares. WASM regenerates
`:position-data` by measuring, so it is left out there."
[]
(uc/snapshot (current-file)
{:position-data? (not (features/active-feature? @st/state "render-wasm/v1"))}))
(defn- mark-baseline
[situation]
(uc/mark-baseline situation (undo-index) (snapshot)))
(defn- settle!
"Emit `event` and wait for it to settle. Resolves with nil, or with the
reason it did not settle."
[event]
(.then (await-step [event])
(fn [result]
(when-not (= :settled result)
(str "did not settle; pending: " (pr-str (describe-pending (:timeout result))))))))
(defn- round-trip-move
"Emit `event` (undo or redo) and check that the file equals the snapshot
`expected` and the undo index `expected-index`, recording failures of
`phase` at `step`. Resolves with `[situation settled?]`."
[situation event step phase expected expected-index]
(.then (settle! event)
(fn [error]
(if error
[(uc/add-error situation step phase error) false]
[(-> situation
(uc/compare-states step phase expected (snapshot))
(uc/compare-index step (keyword (str (name phase) "-index"))
expected-index (undo-index)))
true]))))
(defn- check-step
"The round trip of user step `op`, given the snapshot `before` and the undo
index `index-before` taken before it. Resolves with the situation."
[situation op before index-before]
(let [step (uc/step situation op)
after (snapshot)
index-after (undo-index)]
(if (= index-before index-after)
(js/Promise.resolve (uc/compare-states situation step :no-undo-entry before after))
(.then (round-trip-move situation dwu/undo step :undo before index-before)
(fn [[situation settled?]]
(if settled?
(.then (round-trip-move situation dwu/redo step :redo after index-after)
first)
situation))))))
(defn- repeat-move
"Emit `event` (undo or redo) until `done?` holds, at most `limit` times.
Resolves with `[situation times]`, `situation` holding a failure of
`phase` when a move did not settle."
[situation event phase done? limit]
(letfn [(step [times]
(if (or (done?) (>= times limit))
(js/Promise.resolve [situation times])
(.then (settle! event)
(fn [error]
(if error
[(uc/add-error situation nil phase error) times]
(step (inc times)))))))]
(step 0)))
(defn- check-variant
"The end-of-variant round trip: undo back to the baseline, then redo as many
times. Resolves with the situation."
[situation]
(let [{:keys [depth] :as baseline} (uc/baseline situation)
final (snapshot)
final-index (undo-index)
limit (- final-index depth)]
(if (pos? limit)
(.then (repeat-move situation dwu/undo :variant-undo #(<= (undo-index) depth) limit)
(fn [[situation times]]
(let [situation (uc/compare-states situation nil :variant-undo
(:snapshot baseline) (snapshot))]
(.then (repeat-move situation dwu/redo :variant-redo
#(>= (undo-index) final-index) times)
(fn [[situation _]]
(uc/compare-states situation nil :variant-redo final (snapshot)))))))
(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:
@ -314,7 +430,7 @@
Both are handled by `run-sync-op` (no async settle — any store write is a
synchronous UpdateEvent)."
[op]
(let [op (if (tm/recorded-choice? op) (tm/choice-of op) op)]
(let [op (unwrap op)]
(or (instance? tm/Skip op)
(instance? tm/Test op)
(= :assembly (n/op-kind op))
@ -334,7 +450,10 @@
(let [situation (tm/with-file situation (current-file))
situation (tm/apply-to op situation)]
(st/emit! (install-file-event (tm/file situation)))
situation))
(cond-> situation
(and (::undo-check? situation)
(not (instance? tm/Test (unwrap op))))
(mark-baseline))))
(defn- run-ops
"Async fold over `ops` (concrete operation units, in order — plain ops and/or
@ -348,16 +467,36 @@
[situation ops k]
(if (empty? ops)
(k situation)
(let [op (first ops)]
(let [op (first ops)
kind (let [op (unwrap op)]
(when (satisfies? n/IComponentOperation op)
(n/op-kind op)))
check-step? (and (::undo-check? situation)
(contains? #{:user :frontend-only} kind))
before (when check-step? (snapshot))
index-before (undo-index)]
(if (sync-op? op)
(run-ops (run-sync-op situation op) (rest ops) k)
(.then (await-step (op-events op situation))
(fn [result]
(if (= :settled result)
(run-ops (record-op situation op) (rest ops) k)
(let [situation (record-op situation op)]
(cond
check-step?
(.then (check-step situation (unwrap op) before index-before)
#(run-ops % (rest ops) k))
;; never undo past the state a case's own undo went back to
(and (::undo-check? situation)
(= :undo kind)
(< (undo-index) (:depth (uc/baseline situation))))
(run-ops (mark-baseline situation) (rest ops) k)
:else
(run-ops situation (rest ops) k)))
(do
(t/is false (str "Step did not settle in " step-timeout-ms "ms: "
(pr-str (type (if (tm/recorded-choice? op) (tm/choice-of op) op)))
(pr-str (type (unwrap op)))
"; pending: " (pr-str (describe-pending (:timeout result)))))
(k nil)))))))))
@ -396,11 +535,22 @@
(defn- run-variant
"Set up one variant on the global store and run its ops. `setup` returns a
situation (file + roles). Calls `k` with the final situation."
[setup ops k]
situation (file + roles). With `undo-check?`, runs the undo/redo round
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`)
(cthi/reset-idmap!)
(run-ops (install! (setup)) ops k))
(let [situation (-> (setup)
(assoc ::undo-check? undo-check?)
(uc/with-runner :frontend)
(install!))]
(run-ops (cond-> situation undo-check? (mark-baseline))
ops
(fn [situation]
(if (and situation undo-check?)
(.then (check-variant situation) k)
(k situation))))))
;; --------------------------------------------------------------------------
;; (3) Test-facing check
@ -412,6 +562,10 @@
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
@ -425,7 +579,7 @@
Arities: `(check done case-map)`, which takes the asserter from the case
map's `:asserter`, or `(check done case-map asserter)`."
([done case-map] (check done case-map (:asserter case-map)))
([done {:keys [setup operation]} asserter]
([done {:keys [setup operation] :as case-map} asserter]
(mock/with-mocks
{rp/cmd! mock/rpc-cmd-mock
rx/timer mock/timer-mock}
@ -440,10 +594,13 @@
;; 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]
(when (and asserter situation)
(when situation
(t/testing (str "operations:\n " (tm/describe-applied situation))
(asserter situation)))
(when asserter
(asserter situation))
(uc/check! situation case-map)))
(run-next (rest vs))))))]
(run-next variants))))
done)))