;; 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.geom.point :as gpt] [app.common.geom.shapes :as gsh] [app.common.logic.libraries :as cll] [app.common.logic.shapes :as cls] [app.common.logic.variants :as clv] [app.common.math :as mth] [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] [app.common.types.modifiers :as ctm] [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) ;; --------------------------------------------------------------------------- ;; Geometry operations ;; ;; Unlike `change-property` (a raw attribute write), geometric changes must go ;; through the TRANSFORM pipeline: on the frontend, the interpreter dispatches ;; the real sidebar events (`dwt/increase-rotation`, `dwt/update-dimensions`), ;; whose apply-modifiers step also runs the placement-vs-override classification ;; for component copies (calculate-ignore-tree / check-delta) — which is part of ;; what these operations exist to exercise. The synchronous `apply-to` fallback ;; below performs the geometrically equivalent transform through the production ;; math, but cannot classify placement (that code is frontend-only), so cases ;; using these operations are meant to run through the interpreter. (defrecord Rotate [target angle] tm/IOperation (apply-to [this situation] (let [the-file (tm/file situation) shape-id (tm/target-shape-id situation target) page (thf/current-page the-file) objects (:objects page) shape (get objects shape-id) ;; rotating a container rotates its whole subtree, as the real event does ids (into #{shape-id} (cfh/get-children-ids objects shape-id)) center (gsh/shape->center shape) rotate1 (fn [s] (gsh/transform-shape s (ctm/rotation-modifiers s center angle))) changes (cls/generate-update-shapes (pcb/empty-changes nil (:id page)) ids rotate1 objects {}) file' (thf/apply-changes the-file changes)] (-> situation (tm/with-file file') (tm/record-application this {:target target :angle angle}))))) (defn rotate "Constructor for the rotation operation: rotate the shape named by `target` (a role, a label, or a `(situation -> id)` fn) — including its whole subtree — by `angle` degrees around its center. On the frontend this dispatches the real `dwt/increase-rotation` event." [target angle] (tm/assign-id (->Rotate target angle))) (defrecord ChangeHeight [target value] tm/IOperation (apply-to [this situation] (let [the-file (tm/file situation) shape-id (tm/target-shape-id situation target) page (thf/current-page the-file) objects (:objects page) shape (get objects shape-id) resize1 (fn [s] (gsh/transform-shape s (ctm/resize-modifiers (gpt/point 1 (/ value (:height s))) (gpt/point (:x s) (:y s))))) changes (cls/generate-update-shapes (pcb/empty-changes nil (:id page)) #{(:id shape)} resize1 objects {}) file' (thf/apply-changes the-file changes)] (-> situation (tm/with-file file') (tm/record-application this {:target target :value value}))))) (defn change-height "Constructor for the height-change operation: resize the shape named by `target` to height `value` (width unchanged). On the frontend this dispatches the real `dwt/update-dimensions` event. Implements `IPropertyCheck`, so a `one-of` over property and geometry edits can assert uniformly via `has-property-of`." [target value] (tm/assign-id (->ChangeHeight target value))) (extend-type ChangeHeight IPropertyCheck (applied-property [_node] :height) (applied-value [node] (:value node)) (has-property-of [node shape] (mth/close? (:value node) (:height shape)))) ;; =========================================================================== ;; 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 %)))))))