diff --git a/.serena/memories/frontend/composable-component-tests.md b/.serena/memories/frontend/composable-component-tests.md new file mode 100644 index 0000000000..28c0605569 --- /dev/null +++ b/.serena/memories/frontend/composable-component-tests.md @@ -0,0 +1,317 @@ +# Composable component tests + +A framework for systematically testing Penpot's component subsystem (synchronisation/propagation, +swaps, variant switches, nesting), plus the suite of cases built on it. Lives entirely in the +**frontend** test tree as `.cljs`; it is test-only code with a single consumer (the frontend test +suite, which runs the real app). There is nothing "common" about it — it is not under `app/common`. + +## Core idea +A test is a **composition of operations** over a **situation**, plus assertions. You describe a +test as data (a setup + a sequence of operations) rather than writing bespoke imperative code, and +coverage grows by COMPOSITION: a new variation is one combinator wrapped around existing pieces, +not a copied test. One written case stands for a whole matrix of concrete cases. + +- **Situation** — the in-memory Penpot file value, plus named **roles** (meaningful shapes, e.g. + `:main-instance`/`:copy-instance`), a `:vars` map (named non-shape values), and an ordered + **applied-log** of what ran. +- **Operation** — a step, reified as a DATA record implementing `IOperation` (single method + `apply-to`; `apply` collides with core). Operations are printable, navigable, and enumerable. + Most transform the situation; some do not — hence the genus is "operation", not "transformation" + (`Test` asserts and returns the situation unchanged; `Skip` is a no-op). +- **Assertions** — inline `Test` operations placed in the sequence (assert at intermediate points) + and/or a trailing asserter (a `situation -> any` lambda calling `t/is`). The runner makes NO + judgment; it applies operations and returns the situation. Only *retrieval* helpers live outside + the test (role accessors, `has-property-of`, `applied?`). + +## Principles +- **Operations are data with identity.** Each node gets a unique id at construction (`assign-id`), + records what it did under that id (`record-application`), and is interrogated by identity + (`applied?`, `get-choice`). No flat keyword-tagged log. +- **Drive the real production pipeline.** Every operation routes through the actual production + change functions (`generate-update-shapes`, `generate-component-swap`, `generate-reset-component`, + `generate-sync-file-changes`, …) — never raw field writes, or propagation would have nothing to + react to. The test exercises genuine Penpot logic, not a reimplementation. +- **The frontend runs the real app.** Synchronous file-ops apply directly to the store; event-ops + dispatch the REAL workspace events and await settlement, so the production watcher's AUTOMATIC + propagation is what's under test. Observed semantics are genuine. +- **Roles resolve to ids at setup time.** The global label→id map (`thi`) is shared and + time-varying, so a role is captured as an id when the situation is built; resolving late (across + enumerated variants) would be unsound. Absence throws a diagnostic (never silent nil). +- **Targets resolve at apply-time and may be rebound.** A target is a `(situation -> id)` FUNCTION, + else a currently-bound ROLE, else a LABEL (`target-shape-id`). So one operation targeting a role + follows that role as state-building ops re-point it — which is what lets a single operation be + swept across depth. +- **Enumeration is authored, not exhaustive.** You compose only VALID cases (every `one-of` branch + must be valid against the setup), so outcomes are just pass / fail / error — no not-applicable + cells. Adding a variation across a matrix is a one-expression edit. +- **Naming discipline.** Penpot domain nouns ("component", "variant") must not name framework + abstractions (they collide with real domain concepts). Framework vocabulary is testing concepts + only; an operation may name the domain *action* it performs (`swap`, `propagate`). + +## Composition operators +- `in-sequence` — ordered application, threads the situation; enumerates to the CARTESIAN PRODUCT + of its steps' variants. Operations do not commute, so order is explicit. The workhorse. +- `one-of` — exactly one branch; applying it throws (must be enumerated); enumerates to the UNION + of branches, each wrapped in a `RecordedChoice` so `get-choice` recovers which ran. +- `optional(X)` = `one-of([X, skip])` — sweeps "with and without X" (two variants). `skip` is the + identity operation. The workhorse for adding a state-building step as an axis over a case. +- `test-that [assert-fn]` — an inline `Test`: asserts at this point in the sequence, situation + unchanged. Lets checkpoints sit at intermediate steps. Engine stays clojure.test-free (it just + calls the supplied fn). +- `applied? [situation operation]` — whether that exact node ran (identity-based). Composes with + `optional`/`one-of` for free. REQUIREMENT: bind an operation to a value ONCE and reuse it (in the + composition AND any `Test` querying it), so the id you ask about is the id that ran. + +## Structure (frontend/test/frontend_tests/composable_tests/) +Two boundaries: the domain-agnostic **engine** and the **comp** subject library (about components; +naming the domain is correct there). + +- `core.cljs` (ns `frontend-tests.composable-tests.core`) — the engine, one file: + - situation: `make-situation`, `file`/`with-file`, `with-aux-files`/`aux-files` (carry extra + files, e.g. a library for case H), the applied-log. + - identity & transcript: `assign-id`, `node-id`, `record-application` (also stores a `::kind` + from the record type), `node-data`, `describe-applied` (readable ordered transcript, attached + to every failure so a failing variant in a sweep is identifiable). + - roles & lookup: `role-shape` (strict, by stored id), `has-role?`, `rebind-role`/`rebind-role-id` + (re-point a role — used by state-building ops), `target-shape-id` (fn | role | label), + `shape-by-id` (read a shape whose id is held in a `:vars` object), `resolve-shape`/`-id`. + - protocols: `IOperation`(`apply-to`); `IEnumerable`(`-enumerate`) + `enumerate`. + - operators: `Sequence`/`in-sequence`; `OneOf`/`one-of`/`RecordedChoice`/`get-choice`; + `Skip`/`skip`; `optional`; `Test`/`test-that`; `applied?`; vars `set-var`/`get-var`. + - runners (clojure.test-free): `run-variant`, `run-all` (enumerate → vector, `thi/reset-idmap!` + per variant). + - per-op-interpreter helpers: `sequence-ops` (flatten a concrete variant — flattens `Sequence`, + keeps `RecordedChoice` as a unit), `recorded-choice?`, `choice-of`, `choice-one-of-id`. +- `comp/setups.cljs` — setup fns returning a situation, + role accessors (`main-instance`/ + `copy-instance`/`main-root`/`copy-root`, `copy-child` 1-based): `simple-component-with-copy`, + `simple-component-with-labeled-copy`, `component-with-many-children` (E, F), + `nested-component-with-copy`, `cross-file-component-with-copy` (H: main in a linked library, copy + in the consuming file; primary `:file` = consuming, aux = library), and `empty-situation` (empty + file, no roles — the `:setup` for the sweep cases, whose first operation is `create-component`). +- `comp/nodes.cljs` — the component OPERATIONS. General edit/structure ops: + `change-property [target property value]` (`:fills`/`:opacity`) with its dual `has-property-of` + (`IPropertyCheck`); `change-attr`/`has-attr?` are aliases. `add-child`/`remove-child`/`move-child` + (with `IStructuralCheck`). `sync-from-library` (H: `generate-sync-file-changes`, libraries = + primary + aux). `undo` (I; frontend `dwu/undo`). Plus the scenario building blocks below. +- `interpreter.cljs` (ns `frontend-tests.composable-tests.interpreter`) — runs a case against the + real frontend (see "Interpreter"). +- `comp/sync_test.cljs` (ns `frontend-tests.composable-tests.comp.sync-test`) — the cases; + registered in `frontend_tests/runner.cljs`. + +## Scenario object model (behind the sweep cases) +Scenario ops track one or more named component LINEAGES as OBJECTS under `:vars :components` (keyed +by name, e.g. "main"). Grouping a lineage's fields into one object lets several lineages coexist +(a swap targets a DIFFERENT component) and makes each op "read object `name`, update, write back". + +A lineage object has: +- `:main-component-id` — the component the next instantiate/nest uses (advances to the new OUTER + component per `make-nested-component`). +- `:remote-head`/`:remote-rect` — the FIXED deepest origin (the original component everything is + derived from). For a plain lineage this is never re-pointed; a variant nesting DOES re-point it + (see below). +- `:main-head`/`:main-rect` — the current outer main (advances per nesting). +- `:nesting-count`; `:copies`, `:copy-head`/`:copy-rect` (from `instantiate-copy`). +- `:nesting-data` — vector, one entry per level i: `{:main-head, :nested-head, :nested-rect, + :nested-head-parent}`. + - `:nested-head` is the DEEPEST instance at level i — the descendant of the level's copy head + that corresponds to `:remote-head`, found by descending the `:shape-ref` chain (at level 0 the + inner copy itself; deeper, the corresponding shape nested within the outer wrapper). This is THE + SWAP / SWITCH TARGET; it carries a `:component-id`. + - `:nested-head-parent` is the SWAP-STABLE anchor: a swap/switch replaces the head in place but + keeps its parent, so assertions re-resolve parent → current head → rect. + +Accessors / targets (in nodes): `lineage-component-id`, `lineage-rect`, `lineage-copy-rect`, +`lineage-nesting`, `level-rect`/`level-rect-of` (level i's CURRENT rect via the parent anchor); +target-fns `remote-rect-of`/`main-rect-of`/`copy-rect-of` and `nested-head-of` (return a +`(situation -> id)` for use as an operation target). "Corresponds to" across layers follows the +`:shape-ref` CHAIN, matching on chain MEMBERSHIP not terminus (a copy rect refs its near-main, +which carries a further `:shape-ref`, so the terminus over-walks). Single-file setups, so the chain +resolves in the local page objects. + +Scenario operations (each takes a lineage `name`): +- `create-component [name color]` — a component (frame + rect child of `color`); remote == main, + count 0. +- `make-nested-component [name]` — wrap `name`'s component in a NEW OUTER component whose main + contains a COPY of it inside a board (add-frame → instantiate inside → make-component); the OUTER + becomes `:main-component-id`; advance `:main-*`; append a `:nesting-data` entry; bump count. + ITERABLE: `×N` = board-within-board nesting with one rect at the bottom. Each level's + `:nested-head` is the deepest instance there, so swapping/switching it propagates (via the + watcher) outward to copies of it in OUTER levels. +- `instantiate-copy [name]` — instantiate `name`'s current component; track `:copy-head` and the + rect corresponding to its main rect as `:copy-rect`. +- `reset-copy-instance [name]` — reset overrides on `:copy-head` (production + `generate-reset-component`, `:validate? false` — a file-op on the frontend too: the real reset + event reads browser globals and cannot run headless). +- `swap-component [name level target & {:keys [keep-touched?]}]` — swap level `level`'s + `:nested-head` for lineage `target`'s component, via production `generate-component-swap`. + Frontend = the REAL `dwl/component-swap` event, so the watcher AUTOMATICALLY propagates the swap + to copies (incl. deeper levels). A swap replaces the head in place: Penpot keeps the head id, + rewrites it to the new component, stamps a `:swap-slot-` touched group. `keep-touched?` + default false (discards overrides); true is the variant-switch flavour. +- Shared nesting helper `nest-in-new-outer-component [situation name op seek-rect-id seek-head-id + instantiate-inner-fn]` — the contain-outward mechanism behind BOTH nesting ops. Adds the outer + frame, calls `instantiate-inner-fn` to place the inner instance, makes the outer a component, + then computes this level's `:nested-rect`/`:nested-head` as the IMAGES (inside the new inner copy) + of `seek-rect-id`/`seek-head-id` — the FIXED deepest origin — and does the bookkeeping. A flavour + supplies only the two origin ids + the instantiate fn. Seeking the FIXED origin (not the advancing + `:main-*`) is what makes `:nested-head` land on the deepest instance at every level. + `self-or-descendant-corresponding-to` is the chain-descent that also matches the head itself + (needed at level 0, where the inner copy head IS the origin's image). + +## Variant operations +A variant switch IS a keep-touched swap whose target is resolved by a property VALUE (the +production `variants-switch`/`variant-switch` reduces to `component-swap … keep-touched? true`), so +it routes through the SAME `generate-component-swap` and the watcher auto-propagates it across +nesting levels exactly like a swap. +- `make-variant-container [name members]` (sync-op) — build a variant SET synchronously, mirroring + the test-helpers' `add-variant` idiom: a container frame (`:is-variant-container`), each `members` + entry `[value color]` becoming a member component whose ROOT is a child of the container carrying + the shared `:variant-id`/`:variant-name`, then `update-component` stamps `:variant-id` + + `:variant-properties [{:name "Property 1" :value value}]` on the component. Read the container id + via `(thi/id container-label)` only AFTER adding the container frame (`thi/id` returns nil before + the shape exists). Records the set in `:vars` (`variant-set`/`variant-member`/ + `variant-member-component-id` read it back). +- `make-nested-component-with-variant [name set-name value]` (sync-op) — nest a chosen member via + the shared nesting helper, AND re-point the lineage's `:remote-head`/`:remote-rect` to that + member's root/rect: nesting a variant makes the member the new deepest origin, so subsequent plain + `make-nested-component` descends to the variant's image (its `:nested-head`) at every level. +- `switch-variant [target value]` (frontend event) — switch the variant copy head bound to `target` + to the sibling member with property value `value`, via the REAL `dwv/variants-switch` event (which + DISCOVERS the sibling in the container via `find-variant-components`). `target` uses the standard + resolution (role | label | fn), so the op knows nothing about nesting; cases supply + `nested-head-of name i`. + +## Interpreter (interpreter.cljs) +Drives the real app: +- `op->events [op situation]` maps each event-dispatching operation to its real workspace event(s): + `ChangeProperty`→`dwsh/update-shapes` (the SHARED `set-property`, target via `target-shape-id`); + `MoveChild`→`dwsh/relocate-shapes`; `RemoveChild`→`dwsh/delete-shapes`; `AddChild`→`dwsh/add-shape`; + `SyncFromLibrary`→`dwl/sync-file`; `Undo`→`dwu/undo`; `SwapComponent`→`dwl/component-swap`; + `SwitchVariant`→`dwv/variants-switch {:shapes [head] :pos 0 :val value}`. All real events, so the + watcher auto-propagates. +- `sync-op?` ops (`MakeNestedComponent`, `CreateComponent`, `InstantiateCopy`, `ResetCopyInstance`, + `MakeVariantContainer`, `MakeNestedComponentWithVariant`, `Skip`, `Test`) are NOT dispatched as + events: `run-sync-op` runs the shared `apply-to` against a situation whose `:file` is the live + store file, then writes back synchronously. The property under test is still exercised by the + subsequent real-event ops + the watcher. +- It installs the situation's files into the global `st/state` store (primary as current; aux files + tagged `:library-of` the current file so the library-sync machinery treats them as linked), starts + the real `watch-component-changes` and the harness `watch-undo-stack`, then folds the operations: + dispatch events → await settlement → re-read the current file into `:file` → record. Re-reading + `:file` each step is why the shared role accessors keep working. +- `watch-undo-stack` mirrors the production undo-append subscription from `initialize-workspace` + (which the harness does not run); without it `dwu/undo` has an empty stack. +- Settlement (`await-settle`): subscribe to the commit stream, resolve on the first 60ms idle gap + after a commit (captures the edit commit and the watcher's follow-up sync commit), 2000ms timeout. + Debounce-based, not a deterministic per-op stopper. After settling, `op-grace-ms` adds a per-op + grace wait (currently only `SyncFromLibrary`, ~3.2s — see the Running note). +- Thumbnail rendering is stubbed for this suite (`install-thumbnail-noop!` no-ops + `dwth/update-thumbnail`): the propagation watcher schedules thumbnail renders that reach `window`, + absent headless. +- `check [done case-map asserter]` enumerates, runs each variant via the async fold, wraps the + asserter in `describe-applied`, and calls `done`. Per-variant isolation = id-map reset + global + state re-install (the global `st/state` is a shared `defonce`). +- STORE-SWAP IMMUNITY (`original-store`/`restore-global-store!`): many plugins-suite namespaces + `set!` `st/state`/`st/stream` to isolated stores and never restore them. The `app.main.refs` + lenses (through which the watcher observes commits) are okulary lenses bound to the ORIGINAL + atom instance at load time — after such a swap, events commit to a store the watcher cannot see + and ALL propagation dies silently (assertions see base/unsynced state; no error). The interpreter + therefore captures `st/state`/`st/stream` at namespace-LOAD time (before any test runs) and + re-`set!`s them at the start of every variant, making the harness immune to run order. Diagnosed + by bisecting the runner's deterministic execution order (it is NOT the `test-namespaces` vector + order: `t/test-vars-block` groups vars by namespace, and the group-by hash order decides — same + order locally and in CI). + +## Cases +Asserters are inline; no `doseq`, no count assertions. +- **B** — an override on the copy survives a later main change (override present + `:touched` + contains the fill group + `:shape-ref` present). +- **C** — attribute sweep via `one-of {fills, opacity}`: assert `(has-attr? (get-choice …) copy)` + per enumerated variant. +- **D** — `add-child` to the main gives the copy a ref-integral child (`is-main-of?` + + `parent-of?` + untouched). +- **E** — `remove-child` of the MIDDLE of three: survivors keep order `[child1, child3]`, + `:shape-ref` intact, untouched (middle removal is where index maintenance is tested). +- **F** — `move-child` of child1 to index 2: copy mirrors `[child2, child1, child3]`, identity + preserved. +- **H** — locality (cross-file): main in a linked library, copy in the consuming (current) file, + library main diverged. The in-file watcher does not cross a library boundary; the cross-file + mechanism is the library-update action (`sync-from-library` → `sync-file file-id library-id`). + Setup order matters: instantiate the copy first (captures the old value), diverge the library main + after. +- **I** — undo: an edit then `undo`; copy and main return to baseline, copy untouched. A single + `dwu/undo` reverses the whole logical action — the edit AND its auto-propagation — because the two + commits share an undo-group. +- **K** — SYNC-SCENARIO SWEEP (the flagship). On `empty-situation`: `create-component` → two + `(optional make-nested-component)` (depths 0/1/2) → `instantiate-copy` → three `(optional change-*)` + over remote/main/copy → INLINE checkpoints: (1) override-precedence at the copy (copy wins, else + main, else remote — branch via `applied?`), (2) force a copy override and confirm it wins, (3) + after `reset-copy-instance`, copy reverts to main's value if main changed, else remote's. No + explicit propagate (the watcher auto-propagates at all depths, incl. chained remote→deep-copy). +- **L** — SWAP SWEEP. On `empty-situation`: `create-component` (base) + one swap-target lineage per + level → three `make-nested-component` → three `(optional (swap-component "main" i target_i))` → + one `Test` asserting each level's colour. A swap at level i auto-propagates to level i and every + OUTER level until a higher swap overrides; colour at level i = applied swap at highest j<=i, else + base. +- **M** — VARIANT-SWITCH SWEEP (case L with a variant switch instead of the plain swap, driving the + REAL variant-switch machinery). On `empty-situation`: `create-component` (base lineage "main") + + `make-variant-container` (4 peer members `v0..v3`) → ONE `make-nested-component-with-variant + "main" "vset" "v0"` (introduce the variant innermost) + two plain `make-nested-component` + (progressive wraps, so each outer level CONTAINS the one below) → three + `(optional (switch-variant (nested-head-of "main" i) v_{i+1}))` → one `Test` with case L's exact + precedence asserter. Because the single variant instance has a switchable `:nested-head` at EVERY + level and the levels are progressively nested, a switch at level i propagates outward like a swap. + NOTE on structure: ONE variant + plain wraps is required for cross-level propagation (the levels + nest WITHIN each other). Three independent `make-nested-component-with-variant` would nest SIBLING + variants (none a descendant of another), so switches would not propagate between them — the right + construction for a different test (one asserting switches DON'T cross unrelated instances). + +Running: `cd frontend && pnpm run build:test` then `node target/tests/test.js --focus +frontend-tests.composable-tests.comp.sync-test`. To run one case, use var-level focus, e.g. +`…/case-m-variant-switch-scenarios`. NOTE: the production `sync-file` event (case H) additionally +schedules a 3s-delayed `update-file-library-sync-status` RPC, which fails headless (no backend; a +swallowed URL-parse trace is benign). The interpreter absorbs it: `op-grace-ms` makes the run wait +~3.2s after a `SyncFromLibrary` settles, so the failure lands inside case H instead of leaking into +(and potentially destabilising) whichever test runs next. + +## Frontend fidelity — read before extending +The frontend runs the REAL production logic from the dispatched event onward, so observed semantics +are genuine. But it drives a MINIMALLY-ASSEMBLED app: it installs a file into the global store and +starts only the watchers known to be needed. The real app assembles its workspace via +`initialize-workspace`, which wires many subscriptions; the harness reproduces only some. + +The risk is SILENT UNDER-WIRING — a behaviour that works in the real app can be silently absent in +the harness with no error (e.g. the undo stack is empty unless `watch-undo-stack` is started). +Therefore: when adding a case needing app behaviour beyond a raw edit (undo, persistence, selection, +layout, thumbnails, library auto-detection), first check whether that behaviour lives in an +`initialize-workspace` subscription the harness has not wired — and verify by PROBING store state, +not by trusting a green assertion. The harness hand-wires two stand-ins (`install-file-event`, +`watch-undo-stack`); track them for drift. A durable fix would be to drive the real +`initialize-workspace` headlessly (not done — full init may pull in machinery that doesn't run +cleanly headless). + +## Other caveats +- Cross-namespace leaks land in this suite first because it (correctly) uses the real global + store: besides the store swap above, `frontend-tests.helpers.wasm/teardown-wasm-mocks!` used to + `set!` every WASM fn to nil when run against an empty snapshot (double teardown / async misuse of + `with-wasm-mocks*`), which a leaked debounced `resize-wasm-text` event then tripped over during + our cases (a "Store error: initialized? is not a function"). The teardown is now guarded + (no-op on empty snapshot). If a new inexplicable full-run-only failure appears here, suspect + leaked global state from a preceding namespace before suspecting the framework. +- INLINE `Test` exceptions on the frontend are UNCAUGHT (they run during the async fold, not under + `check`'s try): a throwing checkpoint crashes the whole runner rather than failing one test. +- A `RecordedChoice` wrapping a `Sequence` (i.e. `(optional (in-sequence […]))`) is NOT flattened by + `sequence-ops`, so `op->events` chokes on the `Sequence`. Use independent optionals instead (as + case K does with two `(optional make-nested-component)`), or have the interpreter recurse into a + choice's composite alternative. +- The Serena symbol index / clj-kondo cache for `nodes.cljs` can go STALE and report PHANTOM symbols + or spurious "unresolved symbol" errors against code that compiles — TRUST THE BUILD (a real + `pnpm run build:test`), not the lint or the symbol overview, for this file. +- Label-after-the-fact resolution: `add-child`'s `added-shape` resolves `:new-label` via `thi/id`, + relying on the global label map still reflecting that run's setup — unsound if a structural node + is swept via `one-of`. Fix when needed by capturing the created shape's id at apply-time (as roles + already do). + +## Substrate +`mem:common/test-setup`, `mem:common/component-data-model`, `mem:common/component-swap-pipeline`, +`mem:frontend/testing`. diff --git a/frontend/test/frontend_tests/composable_tests/comp/nodes.cljs b/frontend/test/frontend_tests/composable_tests/comp/nodes.cljs new file mode 100644 index 0000000000..61c91d62c8 --- /dev/null +++ b/frontend/test/frontend_tests/composable_tests/comp/nodes.cljs @@ -0,0 +1,1020 @@ +;; 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 INC Sucursal en España SL + +(ns frontend-tests.composable-tests.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 + `frontend-tests.composable-tests.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." + (:require + [app.common.data :as d] + [app.common.files.changes-builder :as pcb] + [app.common.files.helpers :as cfh] + [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.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.container :as ctn] + [frontend-tests.composable-tests.core :as tm])) + +;; --------------------------------------------------------------------------- +;; 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.) +;; --------------------------------------------------------------------------- + +(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 property value] + (case property + :fills (assoc shape :fills (ths/sample-fills-color :fill-color value)) + :opacity (assoc shape :opacity value) + (throw (ex-info (str "set-property: unsupported property " (pr-str property) + " (supported: :fills, :opacity)") + {: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." + [shape property] + (case property + :fills (-> shape :fills first :fill-color) + :opacity (:opacity shape) + (throw (ex-info (str "read-property: unsupported property " (pr-str property) + " (supported: :fills, :opacity)") + {:property property})))) + +(defrecord ChangeProperty [target property value] + 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 + (pcb/empty-changes nil (:id page)) + #{shape-id} + (fn [shape] (set-property shape property value)) + (:objects page) + {}) + file' (thf/apply-changes the-file changes)] + (-> situation + (tm/with-file file') + (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." + [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)`)." + (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.")) + +(extend-type ChangeProperty + IPropertyCheck + (applied-property [node] (:property node)) + (applied-value [node] (:value node)) + (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) + +;; =========================================================================== +;; Synchronisation-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. +;; =========================================================================== + +(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." + [objects shape] + (loop [s shape, acc #{}] + (let [acc (conj acc (:id s))] + (if-let [ref (:shape-ref s)] + (recur (get objects ref) acc) + 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." + [objects head-id target-id] + (let [descendants (cfh/get-children-ids objects head-id) + matches (filter (fn [id] + (contains? (ref-chain-ids objects (get objects id)) target-id)) + descendants)] + (case (count matches) + 1 (first matches) + 0 (throw (ex-info "descendant-corresponding-to: no descendant corresponds to target" + {:head head-id :target target-id})) + (throw (ex-info "descendant-corresponding-to: ambiguous correspondence" + {: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." + [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 +;; +;; 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) +;; :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.) +;; =========================================================================== + +(defn- get-component-obj + "The component object named `name` from the situation (nil if absent)." + [situation name] + (get (tm/get-var situation :components {}) name)) + +(defn- put-component-obj + "Store/replace the component object named `name`." + [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 name f] + (put-component-obj situation name (f (get-component-obj situation name)))) + +(defn lineage-component-id + "The component id the lineage `name` will instantiate next." + [situation name] + (:main-component-id (get-component-obj situation name))) + +(defn lineage-rect + "The id of lineage `name`'s current main rect (the edit-to-main target)." + [situation name] + (:main-rect (get-component-obj situation name))) + +(defn lineage-nesting + "The `nesting-data` entry for level `i` of lineage `name`." + [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. + +(defn remote-rect-of + "Target: lineage `name`'s fixed remote (deepest-origin) rect." + [name] + (fn [s] (:remote-rect (get-component-obj s name)))) + +(defn main-rect-of + "Target: lineage `name`'s current main rect." + [name] + (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)." + [name] + (fn [s] (:copy-rect (get-component-obj s name)))) + +(defn lineage-copy-rect + "The id of lineage `name`'s current copy rect (for assertions)." + [situation name] + (:copy-rect (get-component-obj situation name))) + +(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." + [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))) + +;; --------------------------------------------------------------------------- +;; create-component — the starting operation: a component with a rect child +;; --------------------------------------------------------------------------- + +(defrecord CreateComponent [name color] + tm/IOperation + (apply-to [this situation] + ;; fresh, name-scoped labels so several lineages don't clash + (let [head-label (keyword (str "sync-" name "-head")) + rect-label (keyword (str "sync-" name "-rect")) + comp-label (keyword (str "sync-" name "-component")) + file' (-> (tm/file situation) + (tho/add-simple-component comp-label head-label rect-label + :child-params + {:fills (ths/sample-fills-color + :fill-color color)})) + head-id (thi/id head-label) + rect-id (thi/id rect-label) + 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 + :main-head head-id :main-rect rect-id + :nesting-count 0 + :nesting-data []}) + (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." + [name color] + (tm/assign-id (->CreateComponent name color))) + +;; --------------------------------------------------------------------------- +;; make-nested-component — wrap the tracked component in a NEW OUTER component +;; +;; 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). +;; --------------------------------------------------------------------------- + +(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." + [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)) + file' (-> the-file + (tho/add-frame outer-frame {:name "OuterFrame"}) + (instantiate-inner-fn outer-frame inner-copy) + (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) + outer-head-id (thi/id outer-frame)] + (-> situation + (tm/with-file file') + (update-component-obj + name + (fn [o] + (-> o + (assoc :main-component-id outer-id + :main-head outer-head-id + :main-rect new-main-rect + :nesting-count (inc level)) + (update :nesting-data conj + {:main-head outer-head-id + :nested-head nested-head + :nested-rect new-main-rect + :nested-head-parent nested-parent})))) + (tm/record-application op {:component name :level level :outer outer-id})))) + +(defrecord MakeNestedComponent [name] + 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}))))))) + +(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))) + +;; --------------------------------------------------------------------------- +;; instantiate-copy — instantiate the lineage's current component, track the copy +;; --------------------------------------------------------------------------- + +(defrecord InstantiateCopy [name] + tm/IOperation + (apply-to [this situation] + (let [the-file (tm/file situation) + obj (get-component-obj situation name) + comp-id (:main-component-id obj) + comp-label (thi/label comp-id) + main-rect (:main-rect obj) + copy-head (keyword (str "sync-" name "-copyhead-" + (count (:copies obj)))) + file' (-> the-file + (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') + (update-component-obj + name + (fn [o] + (-> o + (assoc :copy-head copy-id :copy-rect copy-rect) + (update :copies (fnil conj []) {:copy-head copy-id :copy-rect copy-rect})))) + (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." + [name] + (tm/assign-id (->InstantiateCopy name))) + +;; --------------------------------------------------------------------------- +;; reset-copy-instance — reset overrides on the tracked copy instance +;; --------------------------------------------------------------------------- + +(defrecord ResetCopyInstance [name] + 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') + (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))) + +;; --------------------------------------------------------------------------- +;; swap-component — replace a nested subinstance head with an instance of a +;; different component (the general "Swap component" action), in place. +;; +;; 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` +;; (validation off). 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?] + tm/IOperation + (apply-to [this situation] + (let [the-file (tm/file situation) + page (thf/current-page the-file) + objects (:objects page) + nested-head (:nested-head (lineage-nesting situation name level)) + shape (get objects nested-head) + target-id (lineage-component-id situation target) + libraries {(:id the-file) the-file} + orig-shapes (when keep-touched? + (cfh/get-children-with-self objects nested-head)) + [new-shape _parents changes] + (cll/generate-component-swap (pcb/empty-changes) + objects shape (:data the-file) page libraries + target-id 0 nil {} (boolean keep-touched?)) + [changes _] (if keep-touched? + (clv/generate-keep-touched changes new-shape shape orig-shapes + page libraries (:data the-file)) + [changes nil]) + 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') + (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?))) + +;; =========================================================================== +;; VARIANT operations (case M) — the variant-switch flavour of the swap sweep. +;; +;; 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: only the SWITCH is a real workspace event (`variant-switch` has no +;; pure generator to call directly), so `SwitchVariant` is an EVENT-op: its +;; `apply-to` throws, and the frontend interpreter realises it by dispatching the +;; event. 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. Event-ops do NOT run +;; `apply-to` (only sync-ops do), but 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. +;; =========================================================================== + +(def ^:private variant-property-name + "The single selector property's name (these tests use one property)." + "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} ...]}." + [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." + [situation set-name value] + (let [members (:members (variant-set situation set-name)) + matches (filter #(= value (:value %)) members)] + (case (count matches) + 1 (first matches) + 0 (throw (ex-info "variant-member: no member has that value" + {:set set-name :value value + :available (mapv :value members)})) + (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`." + [situation set-name value] + (:component-id (variant-member situation set-name value))) + +;; --------------------------------------------------------------------------- +;; make-variant-container — build a variant SET synchronously +;; +;; 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). +;; --------------------------------------------------------------------------- + +(defrecord MakeVariantContainer [name members] + 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). + base-file (-> (tm/file situation) + (ths/add-sample-shape container-label + :type :frame + :is-variant-container true)) + variant-id (thi/id container-label) + [file' member-recs] + (reduce + (fn [[file recs] [idx [value color]]] + (let [comp-label (keyword (str "sync-" name "-v" idx "-component")) + 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 + :type :frame + :parent-label container-label + :variant-id variant-id + :variant-name value) + (ths/add-sample-shape rect-label + :parent-label root-label + :fills (ths/sample-fills-color :fill-color color)) + ;; make it a component, then stamp variant metadata ON THE COMPONENT + (thc/make-component comp-label root-label) + (thc/update-component + comp-label + {:variant-id variant-id + :variant-properties [{:name variant-property-name :value value}]}))] + [file2 (conj recs {:value value + :component-label comp-label + :component-id (thi/id comp-label) + :root-label root-label + :rect-label rect-label + :rect-id (thi/id rect-label)})])) + [base-file []] + (map-indexed vector members))] + (-> situation + (tm/with-file file') + (tm/set-var [::variant-set name] + {:variant-id variant-id + :container-label container-label + :members member-recs}) + (tm/record-application this {:variant-set name :variant-id variant-id + :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." + [name members] + (tm/assign-id (->MakeVariantContainer name members))) + +;; --------------------------------------------------------------------------- +;; make-nested-component-with-variant — nest a chosen VARIANT, deeply +;; +;; 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`. +;; --------------------------------------------------------------------------- + +(defrecord MakeNestedComponentWithVariant [name set-name value] + tm/IOperation + (apply-to [this situation] + (let [member (variant-member situation set-name value) + root-id (thi/id (:root-label member)) + rect-id (:rect-id member)] + (-> situation + (nest-in-new-outer-component + name this + rect-id ; origin rect = the variant member's own rect + root-id ; origin head = the variant member's own root + (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." + [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`. FRONTEND-only: +;; dispatches the production `variants-switch`, which DISCOVERS the sibling by value +;; within the variant container and routes through `component-swap` with +;; keep-touched? true — so the watcher auto-propagates it across nesting levels +;; exactly like case L's swap. 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. +;; --------------------------------------------------------------------------- + +(defrecord SwitchVariant [target value] + tm/IOperation + (apply-to [_ _] + (throw (ex-info (str "switch-variant is an EVENT-op with no pure `apply-to` realisation: " + "it is the real `variants-switch` workspace event (which discovers the " + "sibling via the variant container), dispatched by the frontend " + "interpreter. See the VARIANT operations note above.") + {:type ::switch-variant-is-event-op})))) + +(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. FRONTEND-only." + [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`). +;; --------------------------------------------------------------------------- + +(defrecord SyncFromLibrary [] + 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)] + (-> situation + (tm/with-file file') + (tm/record-application this {:library-id library-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)." + [] + (tm/assign-id (->SyncFromLibrary))) + + +;; --------------------------------------------------------------------------- +;; undo — reverse the immediately preceding operation(s) +;; +;; 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. +;; +;; A pure `apply-to` realisation is NOT built: it would require every node to +;; stash its produced change value (the engine `:undo-changes`) into its record +;; so this node could apply the inverse — a retrofit across all nodes that no +;; case needs. It therefore throws loudly rather than pretending. +;; --------------------------------------------------------------------------- + +(defrecord Undo [] + tm/IOperation + (apply-to [_ _] + (throw (ex-info (str "Undo is an EVENT-op with no pure `apply-to` realisation (change " + "values are not stashed per-node). It is realised by the frontend " + "interpreter via the real undo event.") + {:type ::undo-is-event-op})))) + +(defn undo + "Constructor for the undo node (case I). Takes no parameters; on the frontend it + dispatches the real undo, reversing the immediately preceding operation(s)." + [] + (tm/assign-id (->Undo))) + + +;; --------------------------------------------------------------------------- +;; add-child — add a new shape into a (main) component, structurally +;; +;; This is STRUCTURAL modification (changes the tree shape), as opposed to +;; change-attr (attribute modification). It mirrors the established +;; comp-sync-test "add shape" pattern: create a free shape on the page, then +;; relocate it INTO the target parent via the production `generate-relocate` +;; path. 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. +;; --------------------------------------------------------------------------- + +(defrecord AddChild [parent new-label shape-params] + 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) + ;; 1) create the free shape on the page (registers `new-label`) + file-1 (ths/add-sample-shape the-file new-label (or shape-params {})) + page (thf/current-page file-1) + new-id (thi/id new-label) + ;; 2) relocate it into the parent through the production change path + changes (cls/generate-relocate + (-> (pcb/empty-changes nil) + (pcb/with-page-id (:id page)) + (pcb/with-objects (:objects page))) + parent-id ; parent-id + 0 ; to-index + #{new-id}) ; ids to move + file' (thf/apply-changes file-1 changes)] + (-> situation + (tm/with-file file') + (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." + [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 +;; +;; 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. +;; --------------------------------------------------------------------------- + +(defrecord RemoveChild [target] + 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] + (cls/generate-delete-shapes (pcb/empty-changes) + the-file + page + (:objects page) + #{shape-id} + {:components-v2 true}) + file' (thf/apply-changes the-file changes)] + (-> situation + (tm/with-file file') + (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." + [target] + (tm/assign-id (->RemoveChild target))) + + +;; --------------------------------------------------------------------------- +;; move-child — reorder an existing shape within a (main) component +;; +;; 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`. +;; --------------------------------------------------------------------------- + +(defrecord MoveChild [target parent to-index] + tm/IOperation + (apply-to [this situation] + (let [the-file (tm/file situation) + shape-id (tm/resolve-shape-id situation target) + parent-id (tm/resolve-shape-id situation parent) + page (thf/current-page the-file) + changes (cls/generate-relocate + (-> (pcb/empty-changes nil) + (pcb/with-page-id (:id page)) + (pcb/with-objects (:objects page))) + parent-id + to-index + #{shape-id}) + file' (thf/apply-changes the-file changes)] + (-> situation + (tm/with-file file') + (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." + [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." + (added-shape [node situation] + "The shape this node added to the main (live, from the current file).") + (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.")) + +(extend-type AddChild + IStructuralCheck + (added-shape [node situation] + (ths/get-shape (tm/file situation) (:new-label node))) + (materialized-instance-child [node situation container-shape] + (let [the-file (tm/file situation) + added-id (thi/id (:new-label node))] + (->> (:shapes container-shape) + (map #(ths/get-shape-by-id the-file %)) + (d/seek #(= added-id (:shape-ref %))))))) diff --git a/frontend/test/frontend_tests/composable_tests/comp/setups.cljs b/frontend/test/frontend_tests/composable_tests/comp/setups.cljs new file mode 100644 index 0000000000..056da9c450 --- /dev/null +++ b/frontend/test/frontend_tests/composable_tests/comp/setups.cljs @@ -0,0 +1,203 @@ +;; 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 INC Sucursal en España SL + +(ns frontend-tests.composable-tests.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))`)." + (:require + [app.common.files.changes-builder :as pcb] + [app.common.logic.shapes :as cls] + [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] + [frontend-tests.composable-tests.core :as tm])) + +(defn simple-component-with-copy + "A situation with a simple component (root + one child) and one clean copy. + Shape labels: :main-root :main-child :copy-root :copy-child. Roles: + :main-instance -> the main child, :copy-instance -> the copy child." + [] + (let [file (-> (thf/sample-file :file1) + (tho/add-simple-component-with-copy + :component1 :main-root :main-child :copy-root + :copy-root-params {:children-labels [:copy-child]}))] + (tm/make-situation file {:main-instance :main-child + :copy-instance :copy-child + :main-root :main-root + :copy-root :copy-root}))) + + +(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." + [] + (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." + [] + (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")} + :copy-root-params {:children-labels [:copy-child]}))] + (tm/make-situation file {:main-instance :main-child + :copy-instance :copy-child + :main-root :main-root + :copy-root :copy-root}))) + +(defn main-instance + "The main child shape of the configuration (role :main-instance), live." + [situation] + (tm/role-shape situation :main-instance)) + +(defn copy-instance + "The copy child shape of the configuration (role :copy-instance), live." + [situation] + (tm/role-shape situation :copy-instance)) + +(defn main-root + "The main component root shape (role :main-root), live." + [situation] + (tm/role-shape situation :main-root)) + +(defn copy-root + "The copy root shape (role :copy-root), live." + [situation] + (tm/role-shape situation :copy-root)) + + +(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)." + [] + (let [file (-> (thf/sample-file :file1) + (tho/add-component-with-many-children-and-copy + :component1 + :main-root + [:main-child1 :main-child2 :main-child3] + :copy-root + :copy-root-params {:children-labels [:copy-child1 :copy-child2 :copy-child3]}))] + (tm/make-situation file {:main-root :main-root + :copy-root :copy-root + :copy-child-1 :copy-child1 + :copy-child-2 :copy-child2 + :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." + [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." + [] + (let [file (-> (thf/sample-file :file1) + (tho/add-nested-component-with-copy + :component1 :main1-root :main1-child + :component2 :main2-root :main2-nested-head + :copy2-root + :copy2-root-params {:children-labels [:copy2-child]}))] + (tm/make-situation file {:main-instance :main2-nested-head + :copy-instance :copy2-child + :main2-root :main2-root + :copy-root :copy2-root}))) + + +(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 fill-color] + (let [page (thf/current-page library) + main-id (thi/id :main-child) + changes (cls/generate-update-shapes + (pcb/empty-changes nil (:id page)) + #{main-id} + (fn [shape] (assoc shape :fills (ths/sample-fills-color :fill-color fill-color))) + (:objects page) + {})] + (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." + [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) + 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/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs b/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs new file mode 100644 index 0000000000..79a32492a4 --- /dev/null +++ b/frontend/test/frontend_tests/composable_tests/comp/sync_test.cljs @@ -0,0 +1,346 @@ +;; 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 INC Sucursal en España SL + +(ns frontend-tests.composable-tests.comp.sync-test + "Component-behaviour cases authored on the composable test model, run 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 we assert. + + The cases (see `mem:frontend/composable-component-tests` for details): + B — an override on a copy child survives a later main change (touched gate). + C — a sweep (one-of) over several attribute changes, each auto-propagating. + D — a shape added to the main is structurally auto-propagated (ref-integrity). + E — a middle shape removed from the main; survivors keep order. + F — reordering a shape in the main; order auto-propagates, identity preserved. + 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 auto-propagation. + 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. + M — the variant-switch sweep: case L with variant switches. + + Async: each deftest uses `t/async`; `ftm/check` drives the store and calls + `done` when finished." + (:require + [app.common.types.component :as ctk] + [app.common.types.shape-tree :as ctst] + [cljs.test :as t :include-macros true] + [frontend-tests.composable-tests.comp.nodes :as n] + [frontend-tests.composable-tests.comp.setups :as setup] + [frontend-tests.composable-tests.core :as tm] + [frontend-tests.composable-tests.interpreter :as ftm])) + +(def ^:private red "#ff0000") +(def ^:private green "#00ff00") + +;; 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!}) + +;; (Cases A, G, J retired — subsumed by case K's depth-swept propagation scenario.) + +(t/deftest case-b-copy-override-survives-later-main-change + (t/async + done + (let [override (n/change-attr :copy-child :fills green)] ; touch the copy first + (ftm/check + done + {:setup setup/simple-component-with-labeled-copy + ;; override the copy, then change the main; the watcher auto-syncs after + ;; each edit. The override must survive (touched-flag gate). + :operation (tm/in-sequence + [override + (n/change-attr :main-child :fills red)])} + (fn [situation] + (let [copy-child (setup/copy-instance situation)] + (t/is (n/has-attr? override copy-child)) + (t/is (contains? (:touched copy-child) :fill-group)) + (t/is (some? (:shape-ref copy-child))))))))) + +(t/deftest case-c-attribute-sweep-auto-propagates-to-clean-copy + (t/async + done + (let [sweep (tm/one-of + [(n/change-attr :main-child :fills red) + (n/change-attr :main-child :opacity 0.5)])] + (ftm/check + done + {:setup setup/simple-component-with-copy + :operation (tm/in-sequence [sweep])} + (fn [situation] + (let [chosen (tm/get-choice situation sweep)] + (t/is (some? chosen)) + (t/is (n/has-attr? chosen (setup/copy-instance situation))))))))) + +(t/deftest case-d-add-shape-to-main-auto-propagates-to-clean-copy + (t/async + done + (let [add (n/add-child :main-root :main-child-2)] + (ftm/check + done + {:setup setup/simple-component-with-labeled-copy + :operation (tm/in-sequence [add])} + (fn [situation] + (let [copy-root (setup/copy-root situation) + main-new (n/added-shape add situation) + copy-new (n/materialized-instance-child add situation copy-root)] + (t/is (some? copy-new)) + (t/is (ctk/is-main-of? main-new copy-new)) + (t/is (ctst/parent-of? copy-root copy-new)) + (t/is (nil? (:touched copy-new))))))))) + +(t/deftest case-e-remove-shape-from-main-auto-propagates-to-clean-copy + (t/async + done + (let [removal (n/remove-child :main-child2)] + (ftm/check + done + {:setup setup/component-with-many-children + :operation (tm/in-sequence [removal])} + (fn [situation] + (let [copy-root (setup/copy-root situation) + order (vec (:shapes copy-root)) + c1 (setup/copy-child situation 1) + c3 (setup/copy-child situation 3)] + (t/is (= 2 (count order))) + (t/is (= (nth order 0) (:id c1))) + (t/is (= (nth order 1) (:id c3))) + (t/is (some? (:shape-ref c1))) + (t/is (some? (:shape-ref c3))) + (t/is (nil? (:touched c1))) + (t/is (nil? (:touched c3))) + (t/is (nil? (:touched copy-root))))))))) + +(t/deftest case-f-move-shape-in-main-auto-propagates-order-to-clean-copy + (t/async + done + (let [move (n/move-child :main-child1 :main-root 2)] + (ftm/check + done + {:setup setup/component-with-many-children + :operation (tm/in-sequence [move])} + (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))))))))) + +(t/deftest case-i-undo-reverts-edit-and-its-auto-propagation + (t/async + done + ;; UNDO axis (case I), built on case A: change the main (which auto-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. Undo is just another op (`n/undo`); the engine owns + ;; reversal (frontend realisation dispatches the real `dwu/undo`). + (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)] + (ftm/check + done + {:setup setup/simple-component-with-labeled-copy + :operation (tm/in-sequence [change (n/undo)])} + (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))))))))) + +(t/deftest case-h-library-change-propagates-across-file-boundary-on-sync + (t/async + done + ;; LOCALITY axis: 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). Unlike the in-file cases, the watcher does NOT cross the + ;; file boundary; the real app propagates via the library-UPDATE action, so the + ;; transformation is `sync-from-library` (dispatches the real `sync-file`). + ;; `expected` is only an expected-VALUE descriptor (its target is irrelevant; + ;; `has-attr?` uses just attr+value), so the asserter reads exactly like case A. + (let [expected (n/change-attr :main-child :fills red)] + (ftm/check + done + {:setup #(setup/cross-file-component-with-copy red) + :operation (tm/in-sequence [(n/sync-from-library)])} + (fn [situation] + (t/is (n/has-attr? expected (setup/copy-instance situation)))))))) + +(def ^:private blue "#0000ff") + +(t/deftest case-k-synchronisation-scenarios + (t/async + done + ;; 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 ROLES (:remote/:main/:copy-child-rect), so + ;; the same composition holds at any depth. Propagation is AUTOMATIC (no + ;; propagate op). Subsumes the flat/nested propagation cases (A/G/J). + (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))] + (ftm/check + done + {: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/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)))])})))) + +(defn- level-color + "The fill colour of the rect currently 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)) + +(def ^:private base-color "#aaaaaa") +(def ^:private swap-colors ["#ff0000" "#00ff00" "#0000ff"]) ; level 0/1/2 targets + +(t/deftest case-l-swap-scenarios + (t/async + done + ;; 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 (automatically, via + ;; the watcher) 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. (Generalises the + ;; "single swap in copy" diagram across which levels are swapped.) + (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))] + (ftm/check + done + {: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)))))]))})))) + +(t/deftest case-m-variant-switch-scenarios + (t/async + done + ;; 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 + ;; routes through the SAME component-swap as case L (keep-touched? true), so the + ;; watcher auto-propagates it identically: the colour at level i is the switch at + ;; the HIGHEST index j <= i that was applied, else the base member's colour. Same + ;; asserter as L — the test of "a variant switch propagates like a swap". + (let [m "main" ; the nesting lineage (holds the nesting-data) + vset "vset" ; the variant set + vals ["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: the colour at level i is the switch at the + ;; HIGHEST index j <= i that was applied (a switch propagates outward), + ;; else base. + (or (some (fn [j] (when (tm/applied? s (nth switches j)) (nth swap-colors j))) + (range i -1 -1)) + base-color))] + (ftm/check + done + {: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's make-nested-component x3). nested-head + ;; at every level is then the variant (the deepest instance), so a + ;; switch at level i targets it and propagates OUTWARD via the + ;; watcher — 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)))))]))})))) + + diff --git a/frontend/test/frontend_tests/composable_tests/core.cljs b/frontend/test/frontend_tests/composable_tests/core.cljs new file mode 100644 index 0000000000..6c1221658b --- /dev/null +++ b/frontend/test/frontend_tests/composable_tests/core.cljs @@ -0,0 +1,611 @@ +;; 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 INC Sucursal en España SL + +(ns frontend-tests.composable-tests.core + "The domain-agnostic ENGINE of the composable test model (see + `mem:frontend/composable-component-tests`): + + - 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 (`frontend-tests.composable-tests.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." + (:refer-clojure :exclude [apply-to]) + (:require + [app.common.test-helpers.files :as thf] + [app.common.test-helpers.ids-map :as thi] + [app.common.types.shape-tree :as ctst] + [app.common.uuid :as uuid] + [clojure.string :as str])) + +;; --------------------------------------------------------------------------- +;; 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 +;; --------------------------------------------------------------------------- + +;; 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." + ([file] (make-situation file {})) + ([file roles] + {:file file + ;; resolve role labels to ids now, while the labels are valid + :roles (into {} (map (fn [[k label]] [k (thi/id label)])) roles) + :applied [] + :node-data {}})) + +(defn file + "The current in-memory file value of the situation." + [situation] + (: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 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 files-by-id] + (assoc situation :aux-files files-by-id)) + +(defn aux-files + "The situation's auxiliary files (map of file-id -> file), or an empty map. + See `with-aux-files`." + [situation] + (get situation :aux-files {})) + +;; ----- Node identity (central, no inheritance) ----------------------------- +;; +;; 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`. + +(defn assign-id + "Stamp a fresh unique id onto a node record (reserved key ::id). Every node + constructor's final step. Returns the node." + [node] + (assoc node ::id (uuid/next))) + +(defn node-id + "The unique id of a node." + [node] + (::id node)) + +;; ----- 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\"." + [node] + (let [cls (or (some-> node type .-name (str/split #"\.") last) + "node") + ;; CamelCase -> kebab-case + kebab (-> cls + (str/replace #"([a-z0-9])([A-Z])" "$1-$2") + (str/lower-case))] + 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." + [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." + [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." + [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." + [record] + (let [kind (::kind record) + args (dissoc record ::kind)] + (str kind (when (seq args) (str " " (pr-str args)))))) + +(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." + [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. + (let [chosen (:chosen record)] + (when-not (contains? node-data (::id chosen)) + (str "one-of -> " (render-application {::kind (node-kind chosen)})))) + (render-application record))))) + (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." + [situation role-key] + (let [id (get-in situation [:roles role-key]) + page (thf/current-page (file situation))] + (when (nil? id) + (throw (ex-info (str "Unbound role: " (pr-str role-key) + ". Roles present: " (pr-str (vec (keys (:roles situation))))) + {:type ::unbound-role + :role role-key}))) + (let [shape (ctst/get-shape page id)] + (when (nil? shape) + (throw (ex-info (str "Role " (pr-str role-key) " resolves to a shape no longer " + "present in the current page (id " (pr-str id) ").") + {:type ::role-shape-absent + :role role-key + :id id}))) + shape))) + + +(defn has-role? + "Whether `role-key` is currently bound in the situation." + [situation role-key] + (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." + [situation id] + (ctst/get-shape (thf/current-page (file situation)) 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`. +;; --------------------------------------------------------------------------- + +(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 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`." + ([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." + [situation target] + (cond + (fn? target) (target situation) + (has-role? situation target) (:id (role-shape situation target)) + :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. +;; --------------------------------------------------------------------------- + +(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)." + [situation name] + (let [the-file (file situation) + page (thf/current-page the-file) + id (thi/id name) + shape (when id (ctst/get-shape page id))] + (when (nil? shape) + (let [present (->> (vals (:objects page)) + (map (comp thi/label :id)) + (sort) + (vec))] + (throw (ex-info (str "Unbound shape name: " (pr-str name) + ". Shapes present in current page: " (pr-str present)) + {:type ::unbound-shape-name + :name name + :present present})))) + shape)) + +(defn resolve-shape-id + "Resolve a shape binding name (label) to its uuid, with strict-presence + diagnostics (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). +;; --------------------------------------------------------------------------- + +(defprotocol IOperation + (apply-to [operation situation] + "Apply this operation to `situation`, returning a (possibly identical) + situation.")) + + +;; --------------------------------------------------------------------------- +;; 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. +;; --------------------------------------------------------------------------- + +(defprotocol IEnumerable + (-enumerate [operation] + "Return a sequence of fully-concrete operations this one represents.")) + +(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)." + [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. +;; --------------------------------------------------------------------------- + +(declare ->Sequence) + +(defrecord Sequence [steps] + IOperation + (apply-to [_ situation] + (reduce (fn [sit step] (apply-to step sit)) + situation + steps)) + + 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 + (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." + [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. +;; --------------------------------------------------------------------------- + +(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. + IOperation + (apply-to [_ situation] + (-> situation + (assoc-in [:node-data one-of-id] {:chosen chosen}) + (update :applied conj one-of-id) + (->> (apply-to chosen)))) + + IEnumerable + (-enumerate [this] [this])) + +(defrecord OneOf [alternatives] + IOperation + (apply-to [_ _] + (throw (ex-info (str "OneOf cannot be applied directly; it represents a choice " + "and must be enumerated first (the runners do this via `enumerate`).") + {:type ::one-of-applied-directly + :alternative-count (count alternatives)}))) + + 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`." + [alternatives] + (assign-id (->OneOf (vec alternatives)))) + + +(defrecord Skip [] + IOperation + (apply-to [_ situation] situation) + IEnumerable + (-enumerate [self] [self])) + +(defn skip + "The identity operation: applies as a no-op, enumerates to itself. The building + block of `optional`." + [] + (->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. + IOperation + (apply-to [this situation] + (assert-fn situation) + (record-application situation this {})) + IEnumerable + (-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." + [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." + [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." + [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.) +;; --------------------------------------------------------------------------- + +(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." + [{: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." + [{:keys [setup operation]}] + (->> (enumerate operation) + (mapv (fn [variant] + (thi/reset-idmap!) + (run-variant {: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." + [variant] + (cond + (instance? Sequence variant) + (vec (mapcat sequence-ops (:steps variant))) + + :else + [variant])) + +(defn recorded-choice? + "True if `op` is a one-of's enumerated choice wrapper." + [op] + (instance? RecordedChoice op)) + +(defn choice-of + "The concrete operation a `RecordedChoice` selected." + [recorded-choice] + (: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`)." + [recorded-choice] + (:one-of-id recorded-choice)) diff --git a/frontend/test/frontend_tests/composable_tests/interpreter.cljs b/frontend/test/frontend_tests/composable_tests/interpreter.cljs new file mode 100644 index 0000000000..1890fd0faf --- /dev/null +++ b/frontend/test/frontend_tests/composable_tests/interpreter.cljs @@ -0,0 +1,471 @@ +;; 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 INC Sucursal en España SL + +(ns frontend-tests.composable-tests.interpreter + "FRONTEND interpreter + test-facing `check` for the composable test model. + + The generic engine lives in `frontend-tests.composable-tests.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 settlement (so the app's AUTOMATIC propagation — not a + manual sync — is what runs), re-reading the file from the store after each. + 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." + (:require + [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.libraries :as dwl] + [app.main.data.workspace.shapes :as dwsh] + [app.main.data.workspace.thumbnails :as dwth] + [app.main.data.workspace.undo :as dwu] + [app.main.data.workspace.variants :as dwv] + [app.main.store :as st] + [beicon.v2.core :as rx] + [cljs.test :as t] + [frontend-tests.composable-tests.comp.nodes :as n] + [frontend-tests.composable-tests.core :as tm] + [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. +;; -------------------------------------------------------------------------- + +(defonce ^:private original-update-thumbnail (atom nil)) + +(defn- noop-thumbnail-event [] + (ptk/reify ::noop-thumbnail + ptk/WatchEvent + (watch [_ _ _] (rx/empty)))) + +(defn install-thumbnail-noop! + "Replace `dwth/update-thumbnail` with a no-op event so no thumbnail rendering + runs (it would reach `window`, absent headless). Restore with + `restore-thumbnail!`. Idempotent." + [] + (when (nil? @original-update-thumbnail) + (reset! original-update-thumbnail dwth/update-thumbnail) + (set! dwth/update-thumbnail (fn [& _] (noop-thumbnail-event))))) + +(defn restore-thumbnail! + "Restore the real `dwth/update-thumbnail` saved by `install-thumbnail-noop!`." + [] + (when-let [orig @original-update-thumbnail] + (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. +;; -------------------------------------------------------------------------- + +;; 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))) + +(defn op->events + "Map a comp operation record to the real workspace event(s) it dispatches. + `op` is one of the comp node records (frontend-tests.composable-tests.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) + MoveChild -> relocate-shapes (generate-relocate, existing shape) + AddChild -> add-shape (create a shape under the parent) + 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) + (In-file propagation is automatic — the watcher — so no propagate op exists.)" + [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/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/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)] + [(dwv/variants-switch {:shapes [shape] :pos 0 :val value})]) + + (instance? n/MoveChild op) + (let [{:keys [target parent to-index]} op] + [(dwsh/relocate-shapes #{(cthi/id target)} (cthi/id parent) to-index)]) + + (instance? n/RemoveChild op) + (let [{:keys [target]} op] + [(dwsh/delete-shapes #{(cthi/id target)})]) + + (instance? n/AddChild op) + (let [{:keys [parent new-label shape-params]} op] + [(dwsh/add-shape (add-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)]) + + (instance? n/Undo op) + ;; Reverse the previous operation(s) via the real undo event. The workspace + ;; undo stack was maintained automatically by the prior ops' commits. + [dwu/undo] + + :else + (throw (ex-info (str "op->events: no frontend realisation for " (pr-str (type op))) + {:op op})))) + +;; -------------------------------------------------------------------------- +;; (2) Async interpreter +;; -------------------------------------------------------------------------- + +(def ^:private settle-debounce-ms + "Resolve a step once the store's commit stream has been idle this long. This + captures the edit commit AND the watcher's follow-up sync commit, without a + fixed total delay. (Provisional: a fully deterministic per-op stopper would + await that op's specific component-changed/sync; debounce-idle is robust enough + for now.)" + 60) + +(def ^:private settle-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." + [situation] + (let [file (tm/file situation) + aux (tm/aux-files situation)] + (ptk/reify ::install-file-event + ptk/UpdateEvent + (update [_ state] + (assoc state + :current-file-id (:id file) + :current-page-id (cthf/current-page-id file) + :permissions {:can-edit true} + :files (into {(:id file) file} + (map (fn [[lib-id lib]] [lib-id (assoc lib :library-of (:id file))])) + aux)))))) + +(defn- current-file + "Read the live workspace file out of the global store." + [] + (let [st @st/state] + (get-in st [:files (:current-file-id st)]))) + +(defn- await-settle + "Dispatch `events` into the global store, then call `k` once the commit stream + has gone idle (debounced). A hard timeout guarantees progress." + [events k] + (let [stream (ptk/input-stream st/state) + commits (->> stream (rx/filter dch/commit?)) + ;; resolve on first idle gap after a commit, or on timeout + settled (->> commits + (rx/debounce settle-debounce-ms) + (rx/take 1) + (rx/timeout settle-timeout-ms (rx/of :settle/timeout)))] + (rx/subscribe settled (fn [_] (k))) + (doseq [e events] (st/emit! e)))) + +(defn- record-op + "Record an operation's application onto the situation (after its effect settled), + re-reading the file from the store. For a RecordedChoice (one-of), record the + chosen op's application AND the choice under the one-of identity (so the + asserter's `get-choice` works), mirroring `RecordedChoice`'s own `apply-to`." + [situation op] + (let [situation (tm/with-file situation (current-file))] + (if (tm/recorded-choice? op) + (let [chosen (tm/choice-of op) + descriptor (dissoc (into {} chosen) :frontend-tests.composable-tests.core/id)] + (-> situation + ;; record the chosen op under its own identity … + (tm/record-application chosen descriptor) + ;; … and the choice under the one-of's identity, keyed for get-choice + (update :node-data assoc (tm/choice-one-of-id op) {:chosen chosen}) + (update :applied conj (tm/choice-one-of-id op)))) + (let [descriptor (dissoc (into {} op) :frontend-tests.composable-tests.core/id)] + (tm/record-application situation op descriptor))))) + +(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." + [op situation] + (op->events (if (tm/recorded-choice? op) (tm/choice-of op) 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?`)." + [file] + (ptk/reify ::install-file + ptk/UpdateEvent + (update [_ state] + (-> state + (assoc :current-file-id (:id file) + :current-page-id (cthf/current-page-id file)) + (assoc-in [:files (:id file)] file))))) + +(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 (`make-nested-component`, `skip`): a pure file-value transformation + that arranges the CONFIGURATION (deepens it, re-points 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)." + [op] + (let [op (if (tm/recorded-choice? op) (tm/choice-of op) op)] + (or (instance? n/MakeNestedComponent op) + ;; the structural building blocks are also file-transforming: they arrange + ;; the configuration via the shared `apply-to`. ResetCopyInstance is also a + ;; file-op: 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/CreateComponent op) + (instance? n/InstantiateCopy op) + (instance? n/ResetCopyInstance op) + ;; the variant container (test-helper assembly) and variant nesting (the + ;; shared nesting helper) are file-transforming sync-ops; the SWITCH is the + ;; real `variants-switch` workspace event (handled by op->events), not here. + (instance? n/MakeVariantContainer op) + (instance? n/MakeNestedComponentWithVariant op) + (instance? tm/Skip op) + (instance? tm/Test 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." + [situation op] + (let [op' (if (tm/recorded-choice? op) (tm/choice-of op) op) + situation (tm/with-file situation (current-file)) + situation (tm/apply-to op' situation)] + (st/emit! (install-file-event (tm/file situation))) + ;; record the choice too, if this came wrapped in a one-of + (if (tm/recorded-choice? op) + (-> situation + (update :node-data assoc (tm/choice-one-of-id op) {:chosen op'}) + (update :applied conj (tm/choice-one-of-id op))) + situation))) + +(defn- op-grace-ms + "Extra wait AFTER an event-op has settled, before proceeding. Zero for all ops + except `SyncFromLibrary`: the production `sync-file` event additionally + schedules `rx/timer 3000` + an `:update-file-library-sync-status` RPC. There is + no backend in the headless runner, so that delayed call fails (benignly) — but + 3s after the sync it would land INSIDE whatever test is then running, leaking + an error trace across test boundaries (and historically destabilising + whole-suite runs). Waiting it out here absorbs the failure within the test that + caused it." + [op] + (let [op (if (tm/recorded-choice? op) (tm/choice-of op) op)] + (if (instance? n/SyncFromLibrary op) 3200 0))) + +(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 + settlement (plus a per-op grace period, see `op-grace-ms`). The file is re-read + from the store after each. Calls `k` with the final situation." + [situation ops k] + (if (empty? ops) + (k situation) + (let [op (first ops)] + (if (sync-op? op) + (run-ops (run-sync-op situation op) (rest ops) k) + (await-settle + (op-events op situation) + (fn [] + (let [continue #(run-ops (record-op situation op) (rest ops) k) + grace (op-grace-ms op)] + (if (pos? grace) + (js/setTimeout continue grace) + (continue))))))))) + +(defn- watch-undo-stack + "Maintain the workspace UNDO STACK in the (global) store, mirroring the + production subscription in `app.main.data.workspace/initialize-workspace`: + for every local commit with `save-undo?` and non-empty `:undo-changes`, dispatch + `dwu/append-undo`. We start this in the harness because the minimal store setup + does not run the full `initialize-workspace` (which is where the real app wires + it). Re-emitting this event stops any previous instance (so re-install per + variant does not stack watchers)." + [] + (ptk/reify ::watch-undo-stack + ptk/WatchEvent + (watch [_ _ stream] + (let [stopper-s (->> stream (rx/filter (ptk/type? ::watch-undo-stack)))] + (->> stream + (rx/filter dch/commit?) + (rx/map deref) + (rx/filter #(= :local (:source %))) + (rx/mapcat + (fn [{:keys [save-undo? undo-changes redo-changes undo-group tags stack-undo? selected-before]}] + (if (and save-undo? (seq undo-changes)) + (rx/of (dwu/append-undo + {:undo-changes undo-changes + :redo-changes redo-changes + :undo-group undo-group + :tags tags + :selected-before selected-before} + stack-undo?)) + (rx/empty)))) + (rx/take-until stopper-s)))))) + +(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. + {:state st/state :stream st/stream}) + +(defn- restore-global-store! + "Point st/state / st/stream back at the load-time originals (see + `original-store`)." + [] + (set! st/state (:state original-store)) + (set! st/stream (:stream original-store))) + +(defn- run-variant + "Set up one variant on the global store and run its ops. `setup` returns a + situation (file + roles). Restores the global store (a preceding namespace may + have swapped it), installs the file + starts the watcher, then folds the ops. + Calls `k` with the final situation." + [setup ops k] + ;; fresh label space per variant (mirrors the pure `tm/run-all`) + (cthi/reset-idmap!) + (restore-global-store!) + (let [situation (setup)] + (st/emit! (install-situation-event situation)) + (st/emit! (dwl/watch-component-changes)) + (st/emit! (watch-undo-stack)) + (run-ops situation ops k))) + +;; -------------------------------------------------------------------------- +;; (3) Test-facing check +;; -------------------------------------------------------------------------- + +(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. + + 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. + + Arities: `(check done case-map)` or `(check done case-map asserter)`." + ([done case-map] (check done case-map nil)) + ([done {:keys [setup operation]} asserter] + (let [variants (tm/enumerate operation)] + (letfn [(run-next [vs] + (if (empty? vs) + (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)) + (fn [situation] + (when asserter + (t/testing (str "operations:\n " (tm/describe-applied situation)) + (asserter situation))) + (run-next (rest vs))))))] + (run-next variants))))) diff --git a/frontend/test/frontend_tests/helpers/wasm.cljs b/frontend/test/frontend_tests/helpers/wasm.cljs index 497b4c22f1..4529e34582 100644 --- a/frontend/test/frontend_tests/helpers/wasm.cljs +++ b/frontend/test/frontend_tests/helpers/wasm.cljs @@ -202,9 +202,13 @@ (set! wasm.fonts/get-content-fonts mock-get-content-fonts)) (defn teardown-wasm-mocks! - "Restore the original WASM functions saved by `setup-wasm-mocks!`." + "Restore the original WASM functions saved by `setup-wasm-mocks!`. + No-op when there is nothing to restore (`originals` empty): restoring from an + empty snapshot would `set!` every WASM function to nil, breaking any later + code that calls them (e.g. a leaked debounced event firing during a + subsequent test namespace)." [] - (let [orig @originals] + (when-let [orig (not-empty @originals)] (set! wasm.api/initialized? (:initialized? orig)) (set! wasm.api/use-shape (:use-shape orig)) (set! wasm.api/calculate-position-data (:calculate-position-data orig)) diff --git a/frontend/test/frontend_tests/runner.cljs b/frontend/test/frontend_tests/runner.cljs index b6f1a32a80..2adae3e61e 100644 --- a/frontend/test/frontend_tests/runner.cljs +++ b/frontend/test/frontend_tests/runner.cljs @@ -6,6 +6,7 @@ [clojure.tools.cli :refer [parse-opts]] [frontend-tests.basic-shapes-test] [frontend-tests.code-gen-style-test] + [frontend-tests.composable-tests.comp.sync-test] [frontend-tests.copy-as-svg-test] [frontend-tests.data.nitrate-test] [frontend-tests.data.repo-test] @@ -79,6 +80,7 @@ (def test-namespaces ['frontend-tests.basic-shapes-test 'frontend-tests.code-gen-style-test + 'frontend-tests.composable-tests.comp.sync-test 'frontend-tests.copy-as-svg-test 'frontend-tests.data.nitrate-test 'frontend-tests.data.repo-test