mirror of
https://github.com/penpot/penpot.git
synced 2026-10-30 14:30:37 +00:00
✨ Generate shrinkable component composition scenarios
Add a shared generator, authored override shadow and independent oracle. Resolve tuples against current trees, log skips and stable replay paths, and check propagation, sync equivalence, values and exact undo/redo. Keep partial sync in the preceding user's undo group. Validation: 5,000 seeded scenarios passed; common JVM/JS, golden masters, lint and format passed. Focused oracle and sequence checks also pass. Production sync is unchanged by this test harness commit. AI-assisted-by: GPT-6
This commit is contained in:
alonso.torres
parent
31a1fce025
commit
7c5fde720c
@ -15,11 +15,13 @@
|
||||
[app.common.files.helpers :as cfh]
|
||||
[app.common.files.shapes-helpers :as cfsh]
|
||||
[app.common.files.tokens :as cfo]
|
||||
[app.common.geom.modifiers :as gm]
|
||||
[app.common.geom.point :as gpt]
|
||||
[app.common.geom.shapes :as gsh]
|
||||
[app.common.logic.duplicate :as cld]
|
||||
[app.common.logic.instances :as cli]
|
||||
[app.common.logic.libraries :as cll]
|
||||
[app.common.logic.placement :as clp]
|
||||
[app.common.logic.shapes :as cls]
|
||||
[app.common.logic.variant-properties :as clvp]
|
||||
[app.common.logic.variants :as clv]
|
||||
@ -277,15 +279,24 @@
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Geometry operations
|
||||
;;
|
||||
;; The frontend interpreter dispatches the real sidebar events: they build
|
||||
;; the modifiers (frontend code: constraints, pixel snap) and the placement
|
||||
;; step (`clp/calculate-ignore-tree`) decides which copy shapes the change
|
||||
;; touches. Their `apply-to` makes the same transform without either, so the
|
||||
;; pure runner rejects them.
|
||||
;; The frontend interpreter dispatches the sidebar events. The pure runner
|
||||
;; uses the same constraints and placement logic for resize and rotation.
|
||||
;; MoveShape still needs the frontend position event.
|
||||
|
||||
(defn transform-changes
|
||||
"Apply a transform through constraints and the shared placement step."
|
||||
[page shape modifiers]
|
||||
(let [objects (:objects page)
|
||||
tree (gm/set-objects-modifiers {(:id shape) {:modifiers modifiers}} objects)
|
||||
transform (clp/modifiers-transform tree)]
|
||||
(cls/generate-update-shapes
|
||||
(pcb/empty-changes nil (:id page)) (keys tree) transform objects
|
||||
{:ignore-tree (clp/calculate-ignore-tree objects (keys tree) transform #{(:id shape)})
|
||||
:attrs clp/transform-attrs})))
|
||||
|
||||
(defrecord Rotate [target angle]
|
||||
IComponentOperation
|
||||
(op-kind [_] :frontend-only)
|
||||
(op-kind [_] :user)
|
||||
|
||||
tm/IOperation
|
||||
(apply-to [this situation]
|
||||
@ -294,15 +305,8 @@
|
||||
page (thf/current-page the-file)
|
||||
objects (:objects page)
|
||||
shape (get objects shape-id)
|
||||
;; the whole subtree rotates, as with the real event
|
||||
ids (into #{shape-id} (cfh/get-children-ids objects shape-id))
|
||||
center (gsh/shape->center shape)
|
||||
rotate1 (fn [s] (gsh/transform-shape s (ctm/rotation-modifiers s center angle)))
|
||||
changes (cls/generate-update-shapes (pcb/empty-changes nil (:id page))
|
||||
ids
|
||||
rotate1
|
||||
objects
|
||||
{})
|
||||
changes (transform-changes page shape (ctm/rotation-modifiers shape center angle))
|
||||
file' (thf/apply-changes the-file changes)]
|
||||
(-> situation
|
||||
(tm/with-file file')
|
||||
@ -318,7 +322,7 @@
|
||||
|
||||
(defrecord ChangeHeight [target value]
|
||||
IComponentOperation
|
||||
(op-kind [_] :frontend-only)
|
||||
(op-kind [_] :user)
|
||||
|
||||
tm/IOperation
|
||||
(apply-to [this situation]
|
||||
@ -327,15 +331,7 @@
|
||||
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
|
||||
{})
|
||||
changes (transform-changes page shape (ctm/change-size shape nil value))
|
||||
file' (thf/apply-changes the-file changes)]
|
||||
(-> situation
|
||||
(tm/with-file file')
|
||||
@ -1860,7 +1856,7 @@
|
||||
tm/IOperation
|
||||
(apply-to [this situation]
|
||||
(let [the-file (tm/file situation)
|
||||
parent-id (tm/resolve-shape-id situation parent)
|
||||
parent-id (tm/target-shape-id situation parent)
|
||||
page (thf/current-page the-file)
|
||||
objects (:objects page)
|
||||
;; registers `new-label`
|
||||
@ -1895,7 +1891,7 @@
|
||||
tm/IOperation
|
||||
(apply-to [this situation]
|
||||
(let [the-file (tm/file situation)
|
||||
shape-id (tm/resolve-shape-id situation target)
|
||||
shape-id (tm/target-shape-id situation target)
|
||||
page (thf/current-page the-file)
|
||||
[_all-parents changes]
|
||||
(cls/generate-delete-shapes (pcb/empty-changes)
|
||||
|
||||
@ -300,7 +300,10 @@
|
||||
(let [[situation syncs] (if sync?
|
||||
(sync-file situation old-data changes)
|
||||
[situation []])]
|
||||
(push-undo-group situation (into [changes] syncs))))
|
||||
(cond-> (push-undo-group situation (into [changes] syncs))
|
||||
(not sync?)
|
||||
(update ::pending-components (fnil into #{})
|
||||
(changed-components old-data changes)))))
|
||||
(and undo-check? (= kind :user))
|
||||
(check-step op before depth)
|
||||
|
||||
@ -371,6 +374,30 @@
|
||||
;; validated on their own
|
||||
(:sync? opts) (validate-settled!)))))
|
||||
|
||||
(defn step
|
||||
"Run a resolved random operation, retaining the runner's undo stacks.
|
||||
The harness checks each settled group's inverse itself."
|
||||
[situation op]
|
||||
(run-op situation op {:sync? false :undo-check? false}))
|
||||
|
||||
(defn pending-components
|
||||
[situation]
|
||||
(get situation ::pending-components #{}))
|
||||
|
||||
(defn settle
|
||||
"Sync selected pending components in the latest user's undo group."
|
||||
([situation] (settle situation (pending-components situation)))
|
||||
([situation component-ids]
|
||||
(let [{:keys [file syncs]} (sync-cascade (tm/file situation)
|
||||
(tm/aux-files situation)
|
||||
component-ids)
|
||||
stack (get situation ::undo-stack [])]
|
||||
(cond-> (-> situation
|
||||
(tm/with-file file)
|
||||
(update ::pending-components #(apply disj (or % #{}) component-ids)))
|
||||
(and (seq syncs) (seq stack))
|
||||
(assoc ::undo-stack (conj (pop stack) (into (peek stack) syncs)))))))
|
||||
|
||||
(defn run-all
|
||||
"Enumerate `operation` into its concrete variants and run each with
|
||||
`run-variant`, resetting the label map before each setup. Returns the
|
||||
|
||||
252
common/src/app/common/test_helpers/composable/gen.cljc
Normal file
252
common/src/app/common/test_helpers/composable/gen.cljc
Normal file
@ -0,0 +1,252 @@
|
||||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns app.common.test-helpers.composable.gen
|
||||
"Seeded, shrinkable programs over the composable production-path nodes.
|
||||
Tuples resolve their natural-number targets against the current tree.
|
||||
Traces contain tree paths, never random UUIDs, and can be replayed."
|
||||
(:refer-clojure :exclude [flush])
|
||||
(:require
|
||||
[app.common.test-helpers.composable.comp.nodes :as n]
|
||||
[app.common.test-helpers.composable.comp.runner :as r]
|
||||
[app.common.test-helpers.composable.comp.setups :as setup]
|
||||
[app.common.test-helpers.composable.core :as tm]
|
||||
[app.common.test-helpers.composable.oracle :as oracle]
|
||||
[app.common.test-helpers.composable.shadow :as shadow]
|
||||
[app.common.test-helpers.files :as thf]
|
||||
[app.common.test-helpers.ids-map :as thi]
|
||||
[app.common.test-helpers.normalize :as thn]
|
||||
[app.common.types.container :as ctn]
|
||||
[app.common.uuid :as uuid]
|
||||
[clojure.test.check.generators :as gen]))
|
||||
|
||||
(defn tree
|
||||
"Shapes in current page tree order, identified by child-index paths."
|
||||
[situation]
|
||||
(let [objects (:objects (thf/current-page (tm/file situation)))]
|
||||
(letfn [(walk [id path]
|
||||
(let [shape (get objects id)]
|
||||
(cons {:path path :shape shape}
|
||||
(mapcat (fn [[index id]] (walk id (conj path index)))
|
||||
(map-indexed vector (:shapes shape))))))]
|
||||
(vec (mapcat (fn [[index id]] (walk id [index]))
|
||||
(map-indexed vector (:shapes (get objects uuid/zero))))))))
|
||||
|
||||
(defn world
|
||||
[[components depth]]
|
||||
(thi/reset-idmap!)
|
||||
(reduce (fn [s index]
|
||||
(let [name (str "random-" index)]
|
||||
(reduce #(tm/apply-to %2 %1) s
|
||||
[(n/create-component name setup/labeled-fill :size 100)
|
||||
(n/make-nested-component name depth)
|
||||
(n/instantiate-copy name)
|
||||
(n/instantiate-copy name)])))
|
||||
(setup/empty-situation)
|
||||
(range components)))
|
||||
|
||||
(defn candidates
|
||||
[situation model kind scope]
|
||||
(let [objects (:objects (thf/current-page (tm/file situation)))
|
||||
copy-head (fn [shape] (and (:shape-ref shape) (:component-id shape)))
|
||||
top-copy (fn [shape] (and (copy-head shape)
|
||||
(= 1 (count (ctn/get-parent-copy-heads objects shape)))))
|
||||
overridden (fn overridden [id]
|
||||
(or (seq (get model id))
|
||||
(some overridden (:shapes (get objects id)))))]
|
||||
(filterv (fn [{:keys [shape]}]
|
||||
(case kind
|
||||
:edit (or (not= scope 1) (:shape-ref shape))
|
||||
:reset (copy-head shape)
|
||||
:update-main (and (top-copy shape) (overridden (:id shape)))
|
||||
:detach (top-copy shape)
|
||||
(:resize :rotate) (top-copy shape)
|
||||
false))
|
||||
(tree situation))))
|
||||
|
||||
(defn resolve-op
|
||||
"Resolve one tuple. Empty target sets produce an explicit skip."
|
||||
[situation model [kind index property value scope :as tuple]]
|
||||
(let [index (or index 0)
|
||||
items (candidates situation model kind scope)
|
||||
selected (when (seq items) (nth items (mod index (count items))))
|
||||
target (when selected (constantly (get-in selected [:shape :id])))
|
||||
property (nth [:fills :opacity :name] (mod (or property 0) 3))
|
||||
value (case property
|
||||
:fills (nth [setup/labeled-fill "#ff0000" "#00ff00"] (mod (or value 0) 3))
|
||||
:opacity (nth [1 0.4 0.7] (mod (or value 0) 3))
|
||||
:name (str "Label " (mod (or value 0) 3)))
|
||||
op (case kind
|
||||
:sync nil
|
||||
:undo (when (pos? (r/undo-depth situation)) (n/undo))
|
||||
:redo (when (pos? (r/redo-depth situation)) (n/redo))
|
||||
(when target
|
||||
(case kind
|
||||
:edit (n/change-property target property value)
|
||||
:reset (n/reset target)
|
||||
:update-main (n/update-main target)
|
||||
:detach (n/detach target)
|
||||
:resize (n/change-height target (+ 80 (* 20 (mod (or (nth tuple 3 nil) 0) 6))))
|
||||
:rotate (n/rotate target (* 45 (inc (mod (or (nth tuple 3 nil) 0) 4))))
|
||||
nil)))]
|
||||
{:op op :shape (:shape selected) :property property :value value
|
||||
:trace (cond-> {:kind kind :tuple tuple
|
||||
:status (if (or op (= kind :sync)) :executed :skip)}
|
||||
selected (assoc :target (:path selected))
|
||||
(and (nil? op) (not= kind :sync))
|
||||
(assoc :reason (str "No eligible " (name kind) " target")))}))
|
||||
|
||||
(defn- assert-round-trip
|
||||
[before after]
|
||||
(let [undone (r/step after (n/undo))
|
||||
redone (r/step undone (n/redo))]
|
||||
(when-not (= before (oracle/snapshot undone))
|
||||
(oracle/fail :I7 {:phase :undo :diff (thn/diff before (oracle/snapshot undone))}))
|
||||
(when-not (= (oracle/snapshot after) (oracle/snapshot redone))
|
||||
(oracle/fail :I7 {:phase :redo}))))
|
||||
|
||||
(defn settle-state
|
||||
[{:keys [situation model checkpoint] :as state}]
|
||||
(let [settled (r/settle situation)
|
||||
all (keys (get-in (tm/file situation) [:data :components]))
|
||||
full-before (r/sync-cascade (tm/file situation) (tm/aux-files situation) all)
|
||||
full (r/sync-cascade (tm/file settled) (tm/aux-files settled)
|
||||
all)]
|
||||
(oracle/check settled model)
|
||||
(when-not (= (oracle/design-snapshot settled)
|
||||
(oracle/design-snapshot (tm/with-file situation (:file full-before))))
|
||||
(oracle/fail :I6 {}))
|
||||
(when-not (= (oracle/design-snapshot settled)
|
||||
(oracle/design-snapshot (tm/with-file settled (:file full))))
|
||||
(oracle/fail :I5 {}))
|
||||
(when checkpoint (assert-round-trip checkpoint settled))
|
||||
(assoc state :situation settled :checkpoint nil)))
|
||||
|
||||
(defn- update-model
|
||||
[model before after {:keys [shape property value op]} kind]
|
||||
(let [objects (:objects (thf/current-page (tm/file before)))
|
||||
id (:id shape)]
|
||||
(case kind
|
||||
:edit (shadow/edit model shape property value)
|
||||
:reset (shadow/clear-subtree model objects id)
|
||||
:update-main (shadow/update-main model objects id)
|
||||
:detach (shadow/detach model objects
|
||||
(:objects (thf/current-page (tm/file after))) id)
|
||||
(:resize :rotate)
|
||||
(let [shape-after (tm/shape-by-id after id)
|
||||
group :geometry-group]
|
||||
(if (= (shadow/values shape group) (shadow/values shape-after group))
|
||||
model
|
||||
(assoc-in model [id group] (shadow/values shape-after group))))
|
||||
model)))
|
||||
|
||||
(defn step
|
||||
[state tuple]
|
||||
(let [[kind index] tuple
|
||||
state (if (= kind :sync) state (settle-state state))
|
||||
{:keys [situation model]} state
|
||||
{:keys [op trace] :as resolved} (resolve-op situation model tuple)
|
||||
state (update state :trace conj trace)]
|
||||
(if (= :skip (:status trace))
|
||||
state
|
||||
(let [after (if (= kind :sync)
|
||||
(let [pending (sort-by #(str (thi/label %)) (r/pending-components situation))
|
||||
selected (if (and (odd? (or index 0)) (seq pending))
|
||||
[(nth (vec pending) (mod index (count pending)))]
|
||||
pending)]
|
||||
(r/settle situation selected))
|
||||
(r/step situation op))
|
||||
changed (not= (r/undo-depth situation) (r/undo-depth after))
|
||||
history (:undo state)
|
||||
redo (:redo state)
|
||||
next-model (case kind
|
||||
:undo (:before (peek history))
|
||||
:redo (:after (peek redo))
|
||||
(update-model model situation after resolved kind))
|
||||
next-model (or next-model model)
|
||||
state (-> state
|
||||
(assoc :situation after :model next-model)
|
||||
(update-in [:executed kind] (fnil inc 0)))]
|
||||
(oracle/check after next-model (empty? (r/pending-components after)))
|
||||
(case kind
|
||||
:sync state
|
||||
:undo (-> state (assoc :undo (pop history)) (update :redo conj (peek history)))
|
||||
:redo (-> state (assoc :redo (pop redo)) (update :undo conj (peek redo)))
|
||||
(cond-> state
|
||||
changed (-> (assoc :checkpoint (oracle/snapshot situation) :redo [])
|
||||
(update :undo conj {:before model :after next-model}))))))))
|
||||
|
||||
(defn initial-state
|
||||
[world-spec]
|
||||
(let [situation (world world-spec)]
|
||||
{:situation situation :baseline (oracle/snapshot situation)
|
||||
:model {} :trace [] :undo [] :redo [] :executed {}}))
|
||||
|
||||
(defn- check-sequence
|
||||
[{:keys [situation baseline]}]
|
||||
(let [depth (r/undo-depth situation)
|
||||
undone (r/step situation (n/undo depth))
|
||||
redone (nth (iterate #(r/step % (n/redo)) undone) depth)]
|
||||
(when-not (= baseline (oracle/snapshot undone))
|
||||
(oracle/fail :I7 {:phase :sequence-undo}))
|
||||
(when-not (= (oracle/snapshot situation) (oracle/snapshot redone))
|
||||
(oracle/fail :I7 {:phase :sequence-redo}))))
|
||||
|
||||
(defn run
|
||||
"Run a program. A supplied trace must replay the same targets and skips.
|
||||
Failures include the program and labelled trace for a regression."
|
||||
([program] (run program nil))
|
||||
([{:keys [ops] world-spec :world :as program} replay-trace]
|
||||
(let [progress (atom (initial-state world-spec))]
|
||||
(try
|
||||
(doseq [tuple ops]
|
||||
(swap! progress assoc :current tuple)
|
||||
(swap! progress step tuple))
|
||||
(swap! progress settle-state)
|
||||
(check-sequence @progress)
|
||||
(when-not (pos? (reduce + 0 (vals (dissoc (:executed @progress) :sync))))
|
||||
(throw (ex-info "No operations executed" {:type ::empty-program})))
|
||||
(when (and replay-trace (not= replay-trace (:trace @progress)))
|
||||
(throw (ex-info "Replay changed its targets or skips" {:type ::replay-mismatch})))
|
||||
@progress
|
||||
(catch #?(:clj Throwable :cljs :default) cause
|
||||
(throw (ex-info (str (ex-message cause) "\nReplay: (cg/run " (pr-str program) ")"
|
||||
"\nTrace: " (pr-str (:trace @progress)))
|
||||
(assoc (ex-data cause) :program program :trace (:trace @progress)
|
||||
:failing-op (:current @progress))
|
||||
cause)))))))
|
||||
|
||||
(defn check-program
|
||||
"Reject vacuous shrinks and changes of failure signature. test.check must
|
||||
minimize the original invariant failure, rather than a new harness error."
|
||||
[program coverage failure]
|
||||
(try
|
||||
(let [result (run program)]
|
||||
(swap! coverage #(merge-with + % (:executed result)))
|
||||
true)
|
||||
(catch #?(:clj Throwable :cljs :default) error
|
||||
(let [data (ex-data error)
|
||||
signature [(:invariant data) (:type data) (:phase data)
|
||||
(first (:failing-op data))]]
|
||||
(cond
|
||||
(= ::empty-program (:type data)) true
|
||||
(or (= signature @failure) (compare-and-set! failure nil signature))
|
||||
(throw error)
|
||||
:else true)))))
|
||||
|
||||
(def tuple-gen
|
||||
(gen/tuple (gen/elements [:edit :edit :edit :reset :update-main :detach :sync :undo :redo])
|
||||
gen/nat gen/nat gen/nat gen/nat))
|
||||
|
||||
(def program-gen
|
||||
(gen/let [components (gen/choose 2 3)
|
||||
depth (gen/choose 0 2)
|
||||
ops (gen/vector tuple-gen 0 30)]
|
||||
{:world [components depth]
|
||||
;; This executable prefix survives shrinking and guarantees the CI
|
||||
;; coverage floor even at size zero. The random tail changes ordering.
|
||||
:ops (into [[:edit 0 0 1 1] [:sync 0] [:update-main 0]
|
||||
[:edit 0 1 1 1] [:reset 0] [:detach 0] [:undo] [:redo]] ops)}))
|
||||
211
common/src/app/common/test_helpers/composable/oracle.cljc
Normal file
211
common/src/app/common/test_helpers/composable/oracle.cljc
Normal file
@ -0,0 +1,211 @@
|
||||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns app.common.test-helpers.composable.oracle
|
||||
"Checks authored overrides against actual copies. Expected values come
|
||||
from the shadow and near main, never from the sync implementation."
|
||||
(:require
|
||||
[app.common.geom.matrix :as gmt]
|
||||
[app.common.geom.modifiers :as gm]
|
||||
[app.common.geom.point :as gpt]
|
||||
[app.common.geom.shapes :as gsh]
|
||||
[app.common.math :as mth]
|
||||
[app.common.test-helpers.composable.core :as tm]
|
||||
[app.common.test-helpers.composable.shadow :as shadow]
|
||||
[app.common.test-helpers.files :as thf]
|
||||
[app.common.test-helpers.normalize :as thn]
|
||||
[app.common.test-helpers.texts :as thtx]
|
||||
[app.common.types.container :as ctn]
|
||||
[app.common.types.file :as ctf]
|
||||
[app.common.types.modifiers :as ctm]
|
||||
[app.common.types.shape.layout :as ctl]
|
||||
[app.common.types.text :as txt]
|
||||
[clojure.walk :as walk]))
|
||||
|
||||
(defn fail
|
||||
[invariant details]
|
||||
(throw (ex-info (str "Component invariant " (name invariant) " failed")
|
||||
(assoc details :invariant invariant))))
|
||||
|
||||
(defn snapshot
|
||||
[situation]
|
||||
(into {} (map (fn [[id file]]
|
||||
[id (thn/normalize-file file {:position-data? false})]))
|
||||
(assoc (tm/aux-files situation) (:id (tm/file situation)) (tm/file situation))))
|
||||
|
||||
(defn derived-attributes
|
||||
[objects shape]
|
||||
(let [layout-child (and (ctl/any-layout-immediate-child? objects shape)
|
||||
(not (ctl/position-absolute? shape)))
|
||||
text (= :text (:type shape))
|
||||
auto-width (and text (= :auto-width (:grow-type shape)))
|
||||
auto-height (and text (#{:auto-width :auto-height} (:grow-type shape)))
|
||||
width-owned (or auto-width (and (or layout-child (ctl/any-layout? shape))
|
||||
(#{:fill :auto} (:layout-item-h-sizing shape))))
|
||||
height-owned (or auto-height (and (or layout-child (ctl/any-layout? shape))
|
||||
(#{:fill :auto} (:layout-item-v-sizing shape))))]
|
||||
(cond-> #{}
|
||||
layout-child (into #{:x :y})
|
||||
width-owned (conj :width)
|
||||
height-owned (conj :height)
|
||||
(or layout-child width-owned height-owned) (into #{:points :selrect}))))
|
||||
|
||||
(defn design-snapshot
|
||||
"Sync equivalence ignores remote-sync bookkeeping, text run splitting and
|
||||
geometry noise below 0.01 px. Undo snapshots deliberately keep them."
|
||||
[situation]
|
||||
(walk/postwalk
|
||||
(fn [value]
|
||||
(if (and (map? value) (contains? value :parent-id))
|
||||
(let [round-geometry (fn [value]
|
||||
(walk/postwalk #(if (number? %) (/ (mth/round (* % 100)) 100) %) value))]
|
||||
(cond-> (reduce (fn [shape key]
|
||||
(if (contains? shape key) (update shape key round-geometry) shape))
|
||||
(dissoc value :remote-synced)
|
||||
[:x :y :width :height :points :selrect :transform :transform-inverse :rotation])
|
||||
(= :text (:type value)) (update :content thtx/view)))
|
||||
value))
|
||||
(walk/postwalk
|
||||
(fn [value]
|
||||
(if (and (map? value) (:objects value))
|
||||
(update value :objects
|
||||
(fn [objects]
|
||||
(into {} (map (fn [[id shape]]
|
||||
[id (apply dissoc shape (derived-attributes objects shape))])) objects)))
|
||||
value))
|
||||
(snapshot situation))))
|
||||
|
||||
(defn canonical
|
||||
"Design data with shape, component and grid-cell IDs named by tree path.
|
||||
Pure and frontend backends allocate different IDs for the same action."
|
||||
[situation]
|
||||
(let [files (sort-by (comp str key) (snapshot situation))
|
||||
ids (atom {#uuid "00000000-0000-0000-0000-000000000000" :root})]
|
||||
(letfn [(name-tree [objects id path]
|
||||
(when-let [shape (get objects id)]
|
||||
(swap! ids assoc id path)
|
||||
(doseq [[cell-id cell] (:layout-grid-cells shape)]
|
||||
(swap! ids assoc cell-id [path :cell (:row cell) (:column cell)]))
|
||||
(doseq [[index child] (map-indexed vector (:shapes shape))]
|
||||
(name-tree objects child (conj path index)))))]
|
||||
(doseq [[file-index [file-id file]] (map-indexed vector files)]
|
||||
(swap! ids assoc file-id [:file file-index])
|
||||
(doseq [[page-index page-id] (map-indexed vector (get-in file [:data :pages]))
|
||||
:let [page (get-in file [:data :pages-index page-id])]]
|
||||
(swap! ids assoc page-id [:file file-index :page page-index])
|
||||
(doseq [[index child] (map-indexed vector (get-in page [:objects #uuid "00000000-0000-0000-0000-000000000000" :shapes]))]
|
||||
(name-tree (:objects page) child [:file file-index :page page-index index])))
|
||||
(doseq [[index [component-id component]]
|
||||
(map-indexed vector (sort-by (comp str key) (get-in file [:data :components])))
|
||||
:let [path [:file file-index :component index]]]
|
||||
(swap! ids assoc component-id path)
|
||||
(when (:objects component)
|
||||
(name-tree (:objects component) (:main-instance-id component) (conj path :main)))))
|
||||
(walk/postwalk #(if (uuid? %) (get @ids % %) %) (design-snapshot situation)))))
|
||||
|
||||
(defn- child-placement
|
||||
"Place a main child against its expected copy parent. Only lower-level
|
||||
constraint and matrix math is shared with production, not sync code."
|
||||
[main main-parent parent objects]
|
||||
(let [resized (if (and (mth/close? (:width main-parent) (:width parent) 0.01)
|
||||
(mth/close? (:height main-parent) (:height parent) 0.01))
|
||||
objects
|
||||
(let [tree (gm/set-objects-modifiers
|
||||
{(:id main-parent)
|
||||
{:modifiers (ctm/change-size main-parent (:width parent) (:height parent))}}
|
||||
objects)]
|
||||
(reduce-kv (fn [objects id {:keys [modifiers]}]
|
||||
(update objects id gsh/transform-shape modifiers)) objects tree)))
|
||||
main (get resized (:id main))
|
||||
main-parent (get resized (:id main-parent))
|
||||
center (gsh/shape->center main-parent)
|
||||
turn (gmt/multiply (or (:transform parent) (gmt/matrix))
|
||||
(or (:transform-inverse main-parent) (gmt/matrix)))
|
||||
placed (if (gmt/unit? turn) main
|
||||
(gsh/apply-transform main (gmt/transform-in center turn)))]
|
||||
(gsh/move placed (gpt/subtract (gsh/shape->center parent) center))))
|
||||
|
||||
(defn expected-geometry
|
||||
[file container libraries shape]
|
||||
(let [objects (:objects container)]
|
||||
(letfn [(expected [shape visited]
|
||||
(when (contains? visited (:id shape))
|
||||
(fail :I1 {:shape (:name shape) :reason :parent-cycle}))
|
||||
(if (contains? (:touched shape) :geometry-group)
|
||||
shape
|
||||
(if-let [main (ctf/find-ref-shape file container libraries shape :with-context? true)]
|
||||
(let [parent (get objects (:parent-id shape))
|
||||
main-objects (get-in (meta main) [:container :objects])
|
||||
main-parent (get main-objects (:parent-id main))]
|
||||
(if (and (:shape-ref parent) main-parent)
|
||||
(child-placement main main-parent (expected parent (conj visited (:id shape)))
|
||||
main-objects)
|
||||
;; Root placement is authored independently of overrides.
|
||||
(gsh/move main (gpt/subtract (gpt/point (:x shape) (:y shape))
|
||||
(gpt/point (:x main) (:y main))))))
|
||||
shape)))]
|
||||
(expected shape #{}))))
|
||||
|
||||
(defn- geometry-differences
|
||||
[objects shape expected]
|
||||
(let [layout-child (and (ctl/any-layout-immediate-child? objects shape)
|
||||
(not (ctl/position-absolute? shape)))
|
||||
auto-width (and (= :text (:type shape)) (= :auto-width (:grow-type shape)))
|
||||
auto-height (and (= :text (:type shape)) (#{:auto-width :auto-height} (:grow-type shape)))
|
||||
width-owned (or auto-width (and layout-child (#{:fill :auto} (:layout-item-h-sizing shape))))
|
||||
height-owned (or auto-height (and layout-child (#{:fill :auto} (:layout-item-v-sizing shape))))]
|
||||
(cond-> #{}
|
||||
(and (not width-owned) (not (mth/close? (:width shape) (:width expected) 0.01))) (conj :width)
|
||||
(and (not height-owned) (not (mth/close? (:height shape) (:height expected) 0.01))) (conj :height)
|
||||
(and (not layout-child) (not auto-width) (not auto-height)
|
||||
(not (gsh/close-attrs? :points (:points shape) (:points expected) 0.01))) (conj :points))))
|
||||
|
||||
(defn check
|
||||
"I1–I4 and I9. Before settlement only authored groups/values are checked;
|
||||
pending main changes may legitimately leave copies stale."
|
||||
([situation model] (check situation model true))
|
||||
([situation model settled]
|
||||
(let [file (tm/file situation)
|
||||
libraries (assoc (tm/aux-files situation) (:id file) file)]
|
||||
(when settled (thf/validate-file! file libraries))
|
||||
(doseq [page (vals (get-in file [:data :pages-index]))
|
||||
:let [container (ctn/make-container page :page)]
|
||||
shape (vals (:objects page))
|
||||
:when (:shape-ref shape)
|
||||
:let [expected (get model (:id shape) {})
|
||||
touched (set (:touched shape))]]
|
||||
(when-not (= (set (keys expected)) touched)
|
||||
(fail (if (some #(not (contains? expected %)) touched) :I2 :I3)
|
||||
{:shape (:name shape) :expected (set (keys expected)) :actual touched}))
|
||||
(doseq [[group value] expected]
|
||||
(when-not (shadow/same-value? shape group value)
|
||||
(fail :I9 {:shape (:name shape) :group group
|
||||
:expected value :actual (shadow/values shape group)})))
|
||||
(when settled
|
||||
(when-let [main (ctf/find-content-ref-shape file container libraries shape)]
|
||||
(doseq [group (keys shadow/attributes)
|
||||
:when (and (not= group :geometry-group) (not (contains? touched group)))
|
||||
:when (not (and (= group :name-group) (= :text (:type shape))
|
||||
(= (:name main) (txt/generate-shape-name (txt/content->text (:content main))))))
|
||||
;; A copy root's name follows component renaming too.
|
||||
:let [expected (shadow/values main group)
|
||||
actual (shadow/values shape group)]]
|
||||
(when-not (= expected actual)
|
||||
(fail :I4 {:shape (:name shape) :group group
|
||||
:expected expected :actual actual})))
|
||||
(when (= :text (:type shape))
|
||||
(doseq [unit (thtx/override-units (:content main) (:content shape))
|
||||
:let [group (some (fn [[group candidate]] (when (= unit candidate) group)) shadow/text-groups)]
|
||||
:when (not (contains? touched group))]
|
||||
(fail :I4 {:shape (:name shape) :group group :unit unit}))))
|
||||
(when-not (contains? touched :geometry-group)
|
||||
(let [expected (expected-geometry file container libraries shape)
|
||||
attrs (geometry-differences (:objects page) shape expected)]
|
||||
(when (seq attrs)
|
||||
(fail :I4 {:shape (:name shape) :group :geometry-group :attrs attrs
|
||||
:expected (select-keys expected [:width :height :points])
|
||||
:actual (select-keys shape [:width :height :points])}))))))
|
||||
nil)))
|
||||
122
common/src/app/common/test_helpers/composable/shadow.cljc
Normal file
122
common/src/app/common/test_helpers/composable/shadow.cljc
Normal file
@ -0,0 +1,122 @@
|
||||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns app.common.test-helpers.composable.shadow
|
||||
"Authored overrides, kept independently of production touched writes.
|
||||
Each shape id maps groups to the attribute values the user authored."
|
||||
(:require
|
||||
[app.common.test-helpers.composable.comp.nodes :as n]
|
||||
[app.common.test-helpers.texts :as thtx]))
|
||||
|
||||
;; This table is a specification, deliberately not ctk/sync-attrs.
|
||||
(def groups
|
||||
{:fills :fill-group :opacity :layer-effects-group :name :name-group})
|
||||
|
||||
(def attributes
|
||||
{:fill-group [:fills :hide-fill-on-export]
|
||||
:layer-effects-group [:opacity :blend-mode]
|
||||
:name-group [:name]
|
||||
:geometry-group [:width :height :rotation :flip-x :flip-y :content-scale]
|
||||
:constraints-group [:constraints-h :constraints-v :fixed-scroll]
|
||||
:layout-container [:layout]
|
||||
:layout-gap [:layout-gap :layout-gap-type]
|
||||
:layout-padding [:layout-padding :layout-padding-type]
|
||||
:layout-flex-dir [:layout-flex-dir]
|
||||
:layout-align-items [:layout-align-items]
|
||||
:layout-justify-content [:layout-justify-content]
|
||||
:layout-item-margin [:layout-item-margin :layout-item-margin-type]
|
||||
:layout-item-h-sizing [:layout-item-h-sizing]
|
||||
:layout-item-v-sizing [:layout-item-v-sizing]
|
||||
:layout-item-absolute [:layout-item-absolute]
|
||||
:layout-item-z-index [:layout-item-z-index]
|
||||
:layout-item-align-self [:layout-item-align-self]})
|
||||
|
||||
(def text-groups
|
||||
{:text-content-text :letters :text-content-family :family :text-content-weight :weight
|
||||
:text-content-size :size :text-content-line-height :line-height :text-content-spacing :spacing
|
||||
:text-content-decoration :decoration :text-content-case :case :text-content-fills :fills
|
||||
:text-content-typography :typography :text-content-align :align :text-content-direction :direction
|
||||
:text-content-valign :valign})
|
||||
|
||||
(defn values
|
||||
[shape group]
|
||||
(if (contains? text-groups group)
|
||||
{:content (:content shape)}
|
||||
(into {} (map #(vector % (get shape %))) (get attributes group))))
|
||||
|
||||
(defn same-value?
|
||||
[shape group expected]
|
||||
(if-let [unit (get text-groups group)]
|
||||
(not (contains? (thtx/override-units (:content expected) (:content shape)) unit))
|
||||
(= expected (values shape group))))
|
||||
|
||||
(defn edit-text
|
||||
[model before content]
|
||||
(if (:shape-ref before)
|
||||
(let [units (thtx/override-units (:content before) content)]
|
||||
(reduce (fn [model [group unit]]
|
||||
(cond-> model
|
||||
(contains? units unit)
|
||||
(assoc-in [(:id before) group] {:content content})))
|
||||
(cond-> model (seq units) (assoc-in [(:id before) :content-group] {}))
|
||||
text-groups))
|
||||
model))
|
||||
|
||||
(defn duplicate
|
||||
[model before source-id after copy-id]
|
||||
(letfn [(copy-groups [result source-id copy-id]
|
||||
(let [groups (get model source-id)
|
||||
result (cond-> result (seq groups) (assoc copy-id groups))]
|
||||
(reduce (fn [result [source child]] (copy-groups result source child)) result
|
||||
(map vector (:shapes (get before source-id)) (:shapes (get after copy-id))))))]
|
||||
(copy-groups model source-id copy-id)))
|
||||
|
||||
(defn edit
|
||||
[model before property value]
|
||||
(let [after (n/set-property before property value)
|
||||
group (get groups property)]
|
||||
(if (and (:shape-ref before) (not= (get before property) (get after property)))
|
||||
(assoc-in model [(:id before) group] (values after group))
|
||||
model)))
|
||||
|
||||
(defn clear-subtree
|
||||
[model objects root-id]
|
||||
(letfn [(clear [model id]
|
||||
(reduce clear (dissoc model id) (:shapes (get objects id))))]
|
||||
(clear model root-id)))
|
||||
|
||||
(defn detach
|
||||
"A detached outer head loses its groups. Surviving nested copies inherit
|
||||
the authored groups of the near-main links the detach skips."
|
||||
[model before after root-id]
|
||||
(letfn [(inherit [shape]
|
||||
(loop [shape shape groups (get model (:id shape)) seen #{}]
|
||||
(let [ref (:shape-ref shape)]
|
||||
(if (or (nil? ref) (contains? seen ref)
|
||||
(= ref (:shape-ref (get after (:id shape)))))
|
||||
groups
|
||||
(recur (get before ref) (merge (get model ref) groups)
|
||||
(conj seen ref))))))
|
||||
(visit [result id]
|
||||
(let [shape (get after id)
|
||||
groups (when (:shape-ref shape) (inherit (get before id)))
|
||||
result (cond-> (dissoc result id) (seq groups) (assoc id groups))]
|
||||
(reduce visit result (:shapes (get before id)))))]
|
||||
(visit model root-id)))
|
||||
|
||||
(defn update-main
|
||||
"Pushing overrides into a nested copy in a main makes them authored at
|
||||
that level. Ordinary main shapes do not have touched groups."
|
||||
[model objects root-id]
|
||||
(letfn [(push [result id]
|
||||
(let [shape (get objects id)
|
||||
ref (get objects (:shape-ref shape))
|
||||
groups (get model id)
|
||||
result (cond-> (dissoc result id)
|
||||
(and (:shape-ref ref) (seq groups))
|
||||
(update (:id ref) merge groups))]
|
||||
(reduce push result (:shapes shape))))]
|
||||
(push model root-id)))
|
||||
84
common/test/common_tests/logic/composable_gen_test.cljc
Normal file
84
common/test/common_tests/logic/composable_gen_test.cljc
Normal file
@ -0,0 +1,84 @@
|
||||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns common-tests.logic.composable-gen-test
|
||||
(:require
|
||||
[app.common.schema.test :as smt]
|
||||
[app.common.test-helpers.composable.comp.setups :as setup]
|
||||
[app.common.test-helpers.composable.core :as tm]
|
||||
[app.common.test-helpers.composable.gen :as cg]
|
||||
[app.common.test-helpers.composable.oracle :as oracle]
|
||||
[app.common.test-helpers.composable.shadow :as shadow]
|
||||
[app.common.test-helpers.ids-map :as thi]
|
||||
[app.common.test-helpers.shapes :as ths]
|
||||
[clojure.test :as t]))
|
||||
|
||||
(t/use-fixtures :each thi/test-fixture)
|
||||
|
||||
(t/deftest oracle-rejects-phantom-and-missing-overrides
|
||||
(let [situation (setup/simple-component-with-labeled-copy)
|
||||
shape (tm/resolve-shape situation :copy-child)
|
||||
changed (-> (tm/file situation)
|
||||
(ths/update-shape :copy-child :opacity 0.4))
|
||||
authored (shadow/edit {} shape :opacity 0.4)
|
||||
missing (ths/update-shape changed :copy-child :touched nil)]
|
||||
(t/is (nil? (oracle/check situation {})))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/with-file situation changed) {})))
|
||||
(t/is (nil? (oracle/check (tm/with-file situation changed) authored)))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/with-file situation missing) authored)))))
|
||||
|
||||
(t/deftest oracle-rejects-lost-propagation-and-overwritten-values
|
||||
(let [situation (setup/simple-component-with-labeled-copy)
|
||||
shape (tm/resolve-shape situation :copy-child)
|
||||
changed (ths/update-shape (tm/file situation) :copy-child :opacity 0.4)
|
||||
authored (shadow/edit {} shape :opacity 0.4)
|
||||
stale (ths/update-shape changed :copy-child :touched nil)
|
||||
lost (ths/update-shape changed :copy-child :opacity 0.7)]
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/with-file situation stale) {})))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/with-file situation lost) authored)))))
|
||||
|
||||
(t/deftest equal-values-do-not-clear-an-authored-group
|
||||
(let [result (cg/run {:world [2 0] :ops [[:edit 3 1 1] [:edit 3 1 0]
|
||||
[:sync 0] [:undo] [:redo]]})]
|
||||
(t/is (pos? (get-in result [:executed :edit] 0)))
|
||||
(t/is (seq (:trace result)))))
|
||||
|
||||
(t/deftest replay-preserves-targets-and-skips
|
||||
(let [program {:world [2 1] :ops [[:reset 0] [:edit 3 0 1] [:sync 1]
|
||||
[:update-main 0] [:detach 0] [:undo] [:redo]]}
|
||||
result (cg/run program)]
|
||||
(t/is (= (:trace result) (:trace (cg/run program (:trace result)))))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(cg/run program [{:kind :wrong}])))))
|
||||
|
||||
(t/deftest transforms-run-without-a-frontend-and-check-their-inverses
|
||||
(let [result (cg/run {:world [2 0] :ops [[:edit 0 0 1]
|
||||
[:resize 0 0 0] [:sync 0] [:rotate 0 0 0]
|
||||
[:edit 0 0 2] [:undo] [:redo]]})]
|
||||
(t/is (= 1 (get-in result [:executed :resize] 0)))
|
||||
(t/is (= 1 (get-in result [:executed :rotate] 0)))))
|
||||
|
||||
(t/deftest empty-candidates-are-logged-and-empty-runs-rejected
|
||||
(let [result (cg/run {:world [2 0] :ops [[:restore 0] [:edit 0 0 1]]})]
|
||||
(t/is (= :skip (get-in result [:trace 0 :status])))
|
||||
(t/is (string? (get-in result [:trace 0 :reason]))))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(cg/run {:world [2 0] :ops [[:restore 0]]}))))
|
||||
|
||||
(t/deftest random-compositions
|
||||
(let [coverage (atom {})
|
||||
failure (atom nil)]
|
||||
(smt/check!
|
||||
(smt/for [program cg/program-gen]
|
||||
(cg/check-program program coverage failure))
|
||||
:max-size 30)
|
||||
(println "Executed component operations:" (pr-str @coverage))
|
||||
(doseq [kind [:edit :reset :update-main :detach :sync :undo :redo]]
|
||||
(t/is (pos? (get @coverage kind 0)) (str "No executed " kind)))))
|
||||
89
common/test/common_tests/logic/composable_oracle_test.cljc
Normal file
89
common/test/common_tests/logic/composable_oracle_test.cljc
Normal file
@ -0,0 +1,89 @@
|
||||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
;;
|
||||
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
||||
|
||||
(ns common-tests.logic.composable-oracle-test
|
||||
(:require
|
||||
[app.common.files.changes-builder :as pcb]
|
||||
[app.common.geom.modifiers :as gm]
|
||||
[app.common.geom.point :as gpt]
|
||||
[app.common.geom.shapes :as gsh]
|
||||
[app.common.logic.placement :as clp]
|
||||
[app.common.logic.shapes :as cls]
|
||||
[app.common.test-helpers.components :as thc]
|
||||
[app.common.test-helpers.composable.core :as tm]
|
||||
[app.common.test-helpers.composable.oracle :as oracle]
|
||||
[app.common.test-helpers.composable.shadow :as shadow]
|
||||
[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.modifiers :as ctm]
|
||||
[clojure.test :as t]))
|
||||
|
||||
(t/use-fixtures :each thi/test-fixture)
|
||||
|
||||
(defn- sample
|
||||
[constraint]
|
||||
(-> (thf/sample-file :file1)
|
||||
(tho/add-frame :main-root {:width 100 :height 100})
|
||||
(tho/add-rect :main-child {:parent-label :main-root :x 20 :y 10
|
||||
:width 30 :height 20
|
||||
:constraints-h constraint :constraints-v :top})
|
||||
(thc/make-component :component1 :main-root)
|
||||
(thc/instantiate-component :component1 :copy-root :children-labels [:copy-child])))
|
||||
|
||||
(defn- transform
|
||||
[file label modifiers]
|
||||
(let [page (thf/current-page file)
|
||||
objects (:objects page)
|
||||
id (thi/id label)
|
||||
tree (gm/set-objects-modifiers {id {:modifiers modifiers}} objects)
|
||||
change (clp/modifiers-transform tree)]
|
||||
(thf/apply-changes file
|
||||
(cls/generate-update-shapes
|
||||
(pcb/empty-changes nil (:id page)) (keys tree) change objects
|
||||
{:ignore-tree (clp/calculate-ignore-tree objects (keys tree) change #{id})
|
||||
:attrs clp/transform-attrs}))))
|
||||
|
||||
(defn- geometry-model
|
||||
[file]
|
||||
{(thi/id :copy-root) {:geometry-group (shadow/values (ths/get-shape file :copy-root)
|
||||
:geometry-group)}})
|
||||
|
||||
(t/deftest oracle-accepts-placement-and-constraint-resize
|
||||
(doseq [constraint [:scale :leftright :left :center]]
|
||||
(let [file (sample constraint)
|
||||
root (ths/get-shape file :copy-root)
|
||||
resized (transform file :copy-root (ctm/change-size root 200 100))
|
||||
rotated (transform resized :copy-root
|
||||
(ctm/rotation-modifiers (ths/get-shape resized :copy-root)
|
||||
(gsh/shape->center (ths/get-shape resized :copy-root))
|
||||
90))]
|
||||
(t/is (nil? (oracle/check (tm/make-situation file) {})))
|
||||
(t/is (nil? (oracle/check (tm/make-situation resized) (geometry-model resized))))
|
||||
(t/is (nil? (oracle/check (tm/make-situation rotated) (geometry-model rotated)))))))
|
||||
|
||||
(t/deftest oracle-rejects-wrong-child-position-and-size
|
||||
(let [file (sample :left)
|
||||
page (thf/current-page file)
|
||||
change (fn [f]
|
||||
(thf/apply-changes
|
||||
file (cls/generate-update-shapes
|
||||
(pcb/empty-changes nil (:id page)) #{(thi/id :copy-child)}
|
||||
f (:objects page) {:ignore-touched true})))
|
||||
moved (change #(gsh/move % (gpt/point 5 0)))
|
||||
resized (change #(gsh/transform-shape % (ctm/change-size % 40 20)))]
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/make-situation moved) {})))
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/make-situation resized) {})))))
|
||||
|
||||
(t/deftest oracle-rejects-unmarked-constraint-differences
|
||||
(let [file (-> (sample :left)
|
||||
(ths/update-shape :copy-child :constraints-h :right)
|
||||
(ths/update-shape :copy-child :touched nil))]
|
||||
(t/is (thrown? #?(:clj Exception :cljs js/Error)
|
||||
(oracle/check (tm/make-situation file) {})))))
|
||||
@ -194,8 +194,8 @@
|
||||
(:type (ex-data e)))))
|
||||
|
||||
(t/deftest frontend-only-operations-are-rejected
|
||||
(t/is (= ::r/frontend-only (error-type (n/rotate :main-root 45))))
|
||||
(t/is (= ::r/frontend-only (error-type (n/change-height :main-root 50)))))
|
||||
(t/is (= ::r/frontend-only (error-type (n/move-shape :main-root 20 0))))
|
||||
(t/is (= ::r/frontend-only (error-type (n/undo-before-sync :main-child :fills red)))))
|
||||
|
||||
;; A user operation that forgets to record its changes.
|
||||
(defrecord UnrecordedEdit []
|
||||
|
||||
@ -70,6 +70,8 @@
|
||||
[common-tests.logic.comp-reset-test]
|
||||
[common-tests.logic.comp-sync-test]
|
||||
[common-tests.logic.comp-touched-test]
|
||||
[common-tests.logic.composable-gen-test]
|
||||
[common-tests.logic.composable-oracle-test]
|
||||
[common-tests.logic.composable-runner-test]
|
||||
[common-tests.logic.composable-sync-test]
|
||||
[common-tests.logic.copying-and-duplicating-test]
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user