diff --git a/backend/src/app/graph/overlay.clj b/backend/src/app/graph/overlay.clj new file mode 100644 index 0000000000..f7ab3e7a4d --- /dev/null +++ b/backend/src/app/graph/overlay.clj @@ -0,0 +1,359 @@ +;; 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 app.graph.overlay + "Datascript index over a Penpot document: identity, type, and topology. + + The overlay is an index over what Penpot's helpers read, never a + reimplementation of them. `app.common.types.component/instance-head?`, + `app.common.types.container/get-parent-heads`, + `app.common.types.file/find-ref-shape` and their relatives stay the + correctness oracle; the overlay's job is to make the questions those + helpers answer by scanning cheap to reach at scale + (docs.local/graph/20260819-report-graph-overlay-datascript.md). + + Entity identity is the (container, shape) pair, never the shape id + alone. Shape ids are stable but repeat across containers: `uuid/zero` + keys the root frame of every page, duplicated pages share non-root ids, + and a deleted component keeps its own copy of the main-instance subtree + under the same ids (`app.common.types.file/load-component-objects`). + The builder therefore mints one entity per (container, shape) pair, and + parent links are datascript entity references, so topology is interned + by construction. + + The namespace is deliberately JVM-free (no imports, no interop): the + same code moves to the browser worker as a `.cljc` rename when the + mirror experiment lands, which is the point of choosing datascript." + (:require + [app.common.types.text :as txt] + [app.common.types.component :as ctk] + [app.common.types.tokens-lib :as ctob] + [datascript.core :as d])) + +(def schema-version + "penpot-graph-overlay-1") + +(def schema + "Only identity, type, topology, and the attributes a standing query has + asked for. Heavy attributes (geometry, style payloads) stay in the + document, which the holder of the overlay already has. + + Color references are stored per source (`fill`, `stroke`, text content) + rather than as one union, because the sync path receives `:set` ops one + attribute at a time and must be able to rebuild each contribution + independently. The `uses-color` rule in `app.graph.overlay.queries` + reunites them." + {;; document + :document/id {:db/unique :db.unique/identity} + ;; containers: pages, and components that carry their own :objects + :container/id {:db/unique :db.unique/identity} + :container/document {:db/valueType :db.type/ref} + ;; shapes: identity is the (container, shape) pair + :shape/id {:db/index true} + :shape/container {:db/valueType :db.type/ref} + :shape/parent {:db/valueType :db.type/ref} + :shape/name {:db/index true} + :shape/component-id {:db/index true} + :shape/component-file {:db/index true} + :shape/shape-ref {:db/index true} + :shape/swap-slot {:db/index true} + ;; asset links (the beadpot ledger's asset link transforms) + :shape/fill-color {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many} + :shape/stroke-color {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many} + :shape/text-color {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many} + :shape/uses-typography {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many} + ;; components (the record, distinct from any container it may carry) + :component/id {:db/unique :db.unique/identity} + :component/document {:db/valueType :db.type/ref} + ;; library assets + :color/id {:db/unique :db.unique/identity} + :color/document {:db/valueType :db.type/ref} + :typography/id {:db/unique :db.unique/identity} + :typography/document {:db/valueType :db.type/ref} + :token-set/id {:db/unique :db.unique/identity} + :token-set/document {:db/valueType :db.type/ref} + :token/id {:db/unique :db.unique/identity} + :token/name {:db/index true} + :token/set {:db/valueType :db.type/ref} + ;; applied tokens: one entity per (shape, property, token), because an + ;; edge with a payload needs a relation entity in a triple store + :token-use/shape {:db/valueType :db.type/ref} + :token-use/token {:db/valueType :db.type/ref}}) + +(def shape-type->table + "The Ladybug projection's node table names, kept for parity counting and + for console labels (`app.graph.schema.nodes/shape-node-types`)." + {:frame "Frame" + :group "Group" + :bool "Boolean" + :svg-raw "SVGRaw" + :rect "Rectangle" + :circle "Circle" + :path "Path" + :text "Text" + :image "Image"}) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tempids +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def doc-tempid "doc") + +(defn container-tempid + [container-id] + (str "c/" container-id)) + +(defn shape-tempid + [container-id shape-id] + (str "s/" container-id "/" shape-id)) + +(defn color-tempid [id] (str "col/" id)) +(defn typography-tempid [id] (str "typ/" id)) +(defn token-set-tempid [id] (str "ts/" id)) +(defn token-tempid [id] (str "tk/" id)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reference extraction +;; +;; These read exactly the attributes Penpot's own code reads: fill and +;; stroke color refs as `app.common.types.color/stroke->color` does, +;; typography refs from text content nodes as +;; `app.common.types.typography` does via `txt/node-seq`, swap slots via +;; `ctk/get-swap-slot`. None of the predicates is reimplemented. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn fill-color-ref-ids + "Library color ids referenced by a `:fills` vector." + [fills] + (into #{} (keep :fill-color-ref-id) fills)) + +(defn stroke-color-ref-ids + "Library color ids referenced by a `:strokes` vector." + [strokes] + (into #{} (keep :stroke-color-ref-id) strokes)) + +(defn content-color-ref-ids + "Library color ids referenced by fills inside text `content` nodes." + [content] + (into #{} + (comp (mapcat :fills) (keep :fill-color-ref-id)) + (some-> content txt/node-seq))) + +(defn content-typography-ref-ids + "Typography ids referenced by text `content` nodes." + [content] + (into #{} (keep :typography-ref-id) (some-> content txt/node-seq))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; entity construction +;; +;; `asset-ctx` abstracts over build and sync: `:colors`, `:typographies` +;; map locally defined asset ids to entity references (string tempids at +;; build time, resolved eids at sync time), and `:tokens-by-name` maps a +;; token name to the references of every token carrying it. Only +;; resolvable references become edges, mirroring beadpot's `node_exists` +;; guard. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- resolvable-parent? + [objects shape] + (let [parent-id (:parent-id shape)] + (and (some? parent-id) + (not= parent-id (:id shape)) + (contains? objects parent-id)))) + +(defn shape-asset-attrs + "The asset-edge attributes of one shape, resolved through `asset-ctx`." + [shape {:keys [colors typographies]}] + (let [ref-vals (fn [m ids] (into [] (keep m) ids)) + fills (ref-vals colors (fill-color-ref-ids (:fills shape))) + strokes (ref-vals colors (stroke-color-ref-ids (:strokes shape))) + content (when (= :text (:type shape)) (:content shape)) + text (ref-vals colors (content-color-ref-ids content)) + typs (ref-vals typographies (content-typography-ref-ids content))] + (cond-> {} + (seq fills) (assoc :shape/fill-color fills) + (seq strokes) (assoc :shape/stroke-color strokes) + (seq text) (assoc :shape/text-color text) + (seq typs) (assoc :shape/uses-typography typs)))) + +(defn shape-attrs + "The plain indexed attributes of one shape (no identity, no topology)." + [shape] + (let [swap-slot (ctk/get-swap-slot shape)] + (cond-> {:shape/type (:type shape)} + (some? (:name shape)) (assoc :shape/name (:name shape)) + (some? (:component-id shape)) (assoc :shape/component-id (:component-id shape)) + (some? (:component-file shape)) (assoc :shape/component-file (:component-file shape)) + (some? (:shape-ref shape)) (assoc :shape/shape-ref (:shape-ref shape)) + (some? swap-slot) (assoc :shape/swap-slot swap-slot)))) + +(defn shape-entity + "Entity map for one shape of one container. + + `container-ref` is the container entity reference: the container tempid + at build time, the resolved eid on the sync path. The parent reference + falls back to it when the parent is absent from `objects` or + self-referential, which covers the page root frame (its `:parent-id` is + itself) and the root copy of a component container (its parent lives on + a page)." + [container-ref container-id objects shape asset-ctx] + (merge {:db/id (shape-tempid container-id (:id shape)) + :shape/id (:id shape) + :shape/container container-ref + :shape/parent (if (resolvable-parent? objects shape) + (shape-tempid container-id (:parent-id shape)) + container-ref)} + (shape-attrs shape) + (shape-asset-attrs shape asset-ctx))) + +(defn token-use-entities + "One (shape, property, token) entity per applied token that resolves. + + Token names are unique within a set but not across sets, so one applied + name may match several tokens; every match links, exactly as beadpot's + name join does (`beadpot.graph.transform.tokens/LinkAppliedTokens`)." + [shape-ref applied-tokens tokens-by-name] + (for [[prop token-name] applied-tokens + token-ref (get tokens-by-name token-name)] + {:token-use/shape shape-ref + :token-use/token token-ref + :token-use/prop prop})) + +(defn container-entities + "Entities for every shape of one container's `:objects` map, plus the + applied-token relation entities. + + The whole map is indexed, not the tree walk from the root: a shape the + tree cannot reach is a document defect the index should expose to + queries rather than hide (the Ladybug projection walks and drops such + shapes with a warning; this is a recorded divergence)." + [container-ref container-id objects asset-ctx] + (into [] + (mapcat (fn [shape] + (cons (shape-entity container-ref container-id objects shape asset-ctx) + (token-use-entities (shape-tempid container-id (:id shape)) + (:applied-tokens shape) + (:tokens-by-name asset-ctx))))) + (vals objects))) + +(defn component-entity + [component] + (cond-> {:db/id (container-tempid (:id component)) + :component/id (:id component) + :component/document doc-tempid} + (some? (:name component)) + (assoc :component/name (:name component)) + (:deleted component) + (assoc :component/deleted true) + (some? (:main-instance-id component)) + (assoc :component/main-instance-id (:main-instance-id component)) + (some? (:main-instance-page component)) + (assoc :component/main-instance-page (:main-instance-page component)))) + +(defn- component-tx + "The component record entity, plus a container over its own `:objects` + when it carries one (deleted components keep the main-instance subtree, + `app.common.types.file/load-component-objects`)." + [component asset-ctx] + (let [objects (:objects component)] + (cond-> [(component-entity component)] + (seq objects) + (-> (conj {:db/id (container-tempid (:id component)) + :container/id (:id component) + :container/kind :component + :container/document doc-tempid}) + (into (container-entities (container-tempid (:id component)) + (:id component) objects asset-ctx)))))) + +(defn- page-tx + [page asset-ctx] + (into [(cond-> {:db/id (container-tempid (:id page)) + :container/id (:id page) + :container/kind :page + :container/document doc-tempid} + (some? (:name page)) (assoc :container/name (:name page)))] + (container-entities (container-tempid (:id page)) + (:id page) (:objects page) asset-ctx))) + +(defn- tokens-tx + "Token set and token entities from the file's tokens lib. + + Only identity, type and set membership: values, resolution and themes + stay in the lib, which `app.common.types.tokens-lib` already answers." + [tokens-lib] + (into [] + (mapcat (fn [set*] + (let [set-id (ctob/get-id set*) + set-name (ctob/get-name set*)] + (cons {:db/id (token-set-tempid set-id) + :token-set/id set-id + :token-set/name set-name + :token-set/document doc-tempid} + (for [token (vals (ctob/get-tokens- set*))] + {:db/id (token-tempid (:id token)) + :token/id (:id token) + :token/name (:name token) + :token/type (:type token) + :token/set (token-set-tempid set-id)}))))) + (some-> tokens-lib ctob/get-sets))) + +(defn- build-tokens-by-name + "Token name -> tempids of every token carrying that name." + [tokens-lib] + (reduce (fn [acc set*] + (reduce-kv (fn [acc _ token] + (update acc (:name token) (fnil conj []) + (token-tempid (:id token)))) + acc + (ctob/get-tokens- set*))) + {} + (some-> tokens-lib ctob/get-sets))) + +(defn- build-asset-ctx + [data] + {:colors (into {} (map (fn [[id _]] [id (color-tempid id)])) + (:colors data)) + :typographies (into {} (map (fn [[id _]] [id (typography-tempid id)])) + (:typographies data)) + :tokens-by-name (build-tokens-by-name (:tokens-lib data))}) + +(defn build-tx + "The full transaction that projects file `data` into an empty overlay. + + `file` supplies `:id` and `:name` when `data` does not carry them." + [data file] + (let [doc-id (or (:id data) (:id file)) + ctx (build-asset-ctx data)] + (-> [(cond-> {:db/id doc-tempid :document/id doc-id} + (some? (:name file)) (assoc :document/name (:name file)))] + (into (map (fn [[id color]] + (cond-> {:db/id (color-tempid id) + :color/id id + :color/document doc-tempid} + (some? (:name color)) (assoc :color/name (:name color))))) + (:colors data)) + (into (map (fn [[id typ]] + (cond-> {:db/id (typography-tempid id) + :typography/id id + :typography/document doc-tempid} + (some? (:name typ)) (assoc :typography/name (:name typ))))) + (:typographies data)) + (into (tokens-tx (:tokens-lib data))) + (into (mapcat #(component-tx (val %) ctx)) (:components data)) + (into (mapcat #(page-tx (get-in data [:pages-index %]) ctx)) + (filter #(get-in data [:pages-index %]) (:pages data)))))) + +(defn build + "Project file `data` into a fresh overlay. Pure: returns a datascript + database value." + ([data] (build data nil)) + ([data file] + (d/db-with (d/empty-db schema) (build-tx data file)))) diff --git a/backend/src/app/graph/overlay/console.clj b/backend/src/app/graph/overlay/console.clj new file mode 100644 index 0000000000..455df30e9b --- /dev/null +++ b/backend/src/app/graph/overlay/console.clj @@ -0,0 +1,155 @@ +;; 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 app.graph.overlay.console + "Free-form Datalog for the debug graph console: parse, gate, run, + format. + + The gate replaces the Cypher binder gate + (`app.graph.ladybug/validate-on-connection!`) with the equivalent + guarantee for datascript: a console query can read anything and execute + nothing. `d/q` cannot transact, so mutation is off the table by + construction; what remains is function clauses. Datascript resolves a + namespace-qualified symbol in call position through `resolve`, which + would hand the console arbitrary code execution + (`[(clojure.core/eval ...)]`), so every symbol in call position must be + a datascript built-in, a built-in aggregate, or a rule from the shared + rule set. Unknown symbols are rejected before the query runs, with the + binder's own courtesy: the error names the symbol." + (:require + [app.common.exceptions :as ex] + [app.graph.overlay.queries :as queries] + [clojure.edn :as edn] + [datascript.built-ins :as bi] + [datascript.core :as d])) + +(def max-rows + "Row cap for console query results; far above expected per-file counts." + 10000) + +(def ^:private control-symbols + "Clause heads that structure a query rather than call a function." + '#{not not-join or or-join and pull}) + +(def ^:private rule-names + (into #{} (map (comp first first)) queries/rules)) + +(def ^:private allowed-call-symbols + (-> #{} + (into (keys bi/query-fns)) + (into (keys bi/aggregates)) + (into control-symbols) + (into rule-names))) + +(defn- collect-call-symbols + "Every symbol in call position anywhere in `form`: heads of seqs (rule + invocations, aggregates, control forms) and of function/predicate + clauses." + [form] + (cond + (seq? form) + (let [head (first form)] + (into (if (symbol? head) [head] []) + (mapcat collect-call-symbols) + (rest form))) + + (coll? form) + (into [] (mapcat collect-call-symbols) form) + + :else [])) + +(defn parse-query + "Parse the console text as EDN. Only data readers for uuid are honoured; + everything else is inert data." + [text] + (try + (let [q (edn/read-string {:readers {'uuid parse-uuid}} text)] + (when-not (or (vector? q) (map? q)) + (ex/raise :type :validation + :code :graph-query-invalid + :hint "a datalog query is a vector or a map")) + q) + (catch clojure.lang.ExceptionInfo e (throw e)) + (catch Exception e + (ex/raise :type :validation + :code :graph-query-invalid + :hint (str "unreadable query: " (ex-message e)))))) + +(defn check-query! + "The gate: reject any call-position symbol that is not a datascript + built-in, aggregate, control form, or shared rule." + [query] + (let [unknown (into (sorted-set) + (remove allowed-call-symbols) + (collect-call-symbols query))] + (when (seq unknown) + (ex/raise :type :validation + :code :graph-query-not-read-only + :hint (str "unknown function(s) in query: " + (pr-str (vec unknown)) + " — the console runs datascript built-ins and the shared rules only"))) + query)) + +(defn- query-sections + "Normalize the vector query form into its keyword sections." + [query] + (if (map? query) + query + (loop [acc {} section nil forms (seq query)] + (if-let [form (first forms)] + (if (keyword? form) + (recur acc form (rest forms)) + (recur (update acc section (fnil conj []) form) section (rest forms))) + acc)))) + +(defn- find-columns + "Column names from the :find clause; `?foo` renders as `foo`, so the + console's `filter_*` graph-view convention carries over verbatim." + [query] + (mapv (fn [el] + (cond + (symbol? el) (let [n (name el)] + (cond-> n (.startsWith ^String n "?") (subs 1))) + :else (pr-str el))) + (remove '#{. ...} (:find (query-sections query))))) + +(defn- wants-rules? + [query] + (some #{'%} (:in (query-sections query)))) + +(defn- normalize-rows + "d/q returns a relation (set of tuples), a scalar, a collection, or a + single tuple depending on the find spec; the console table always wants + rows of cells." + [result] + (cond + (set? result) (mapv vec result) + (sequential? result) (if (and (seq result) (sequential? (first result))) + (mapv vec result) + (mapv vector result)) + (nil? result) [] + :else [[result]])) + +(defn run-query + "Parse, gate, and run `text` against overlay `db`. + + `$` is always supplied; `%` (the shared rule set of + `app.graph.overlay.queries`) is supplied when the query's :in asks for + it. Returns {:columns [...] :rows [...] :truncated? bool :row-count n} + in the shape the console template renders." + [db text] + (let [query (-> text parse-query check-query!) + rows (normalize-rows + (if (wants-rules? query) + (d/q query db queries/rules) + (d/q query db))) + over? (> (count rows) max-rows) + rows (if over? (into [] (take max-rows) rows) rows) + columns (find-columns query)] + {:columns columns + :rows rows + :truncated? over? + :row-count (count rows)})) diff --git a/backend/src/app/graph/overlay/queries.clj b/backend/src/app/graph/overlay/queries.clj new file mode 100644 index 0000000000..540c4b8491 --- /dev/null +++ b/backend/src/app/graph/overlay/queries.clj @@ -0,0 +1,374 @@ +;; 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 app.graph.overlay.queries + "The standing question set over the overlay, plus the rule set the + console shares. + + Division of labour, stated once and applied throughout: **when the + caller holds the document, Penpot's helper is the query.** The upward + walk (`ctn/get-parent-heads` over `cfh/get-parents-with-self`) runs + about 1 500 times faster than the datalog formulation because the + document already encodes it as a pointer chain + (docs.local/graph/20260819-report-graph-overlay-datascript.md). The + functions here exist for the reverse and cross-container questions the + document cannot answer without a full scan, and for callers that hold + only the index. Where a function mirrors a helper, its docstring names + that helper, and the semantic suite pins the equality; the helper stays + the oracle and is never reimplemented here." + (:require + [app.common.uuid :as uuid] + [datascript.core :as d])) + +(def rules + "The shared rule set. Edge kinds that the Ladybug projection + materialized as relationship tables are rules here: they derive from + indexed attributes at query time, so they can never drift from the + attributes they restate. + + The predicates the rules restate live in `app.common.types.component` + and stay authoritative: `instance-head?` is `(some? (:component-id + shape))`, which is exactly the `[?s :shape/component-id _]` clause; + `is-instance-of` requires `component-file` as the head marker just as + `ctk/instance-of?` does; `fills-swap-slot` reads the swap slot that + `ctk/get-swap-slot` extracted at build time." + '[;; ancestors, self included: cfh/get-parents-with-self as a rule + [(anc-or-self ?s ?a) + [(identity ?s) ?a]] + [(anc-or-self ?s ?a) + [?s :shape/parent ?p] + (anc-or-self ?p ?a)] + + ;; strict descendants: cfh/get-children-ids as a rule + [(desc ?a ?d) + [?d :shape/parent ?a]] + [(desc ?a ?d) + [?x :shape/parent ?a] + (desc ?x ?d)] + + ;; IsInstanceOf: ctk/instance-of? against a live component record + [(is-instance-of ?s ?c) + [?s :shape/type :frame] + [?s :shape/component-id ?cid] + [?s :shape/component-file _] + [?c :component/id ?cid] + (not [?c :component/deleted true])] + + ;; RefersTo: is-main-of? read backwards — the instance shape points + ;; at its homologue by :shape-ref, joined on the target's id + [(refers-to ?s ?t) + [?s :shape/shape-ref ?r] + [?t :shape/id ?r]] + + ;; FillsSwapSlot: the swapped-in shape names the replaced slot + [(fills-swap-slot ?s ?t) + [?s :shape/swap-slot ?slot] + [?t :shape/id ?slot] + [?s :shape/id ?sid] + [(not= ?sid ?slot)]] + + ;; UsesColor: the per-source attributes reunited + [(uses-color ?s ?col) + [?s :shape/fill-color ?col]] + [(uses-color ?s ?col) + [?s :shape/stroke-color ?col]] + [(uses-color ?s ?col) + [?s :shape/text-color ?col]] + + ;; UsesToken: the relation entity flattened to an edge + [(uses-token ?s ?t) + [?u :token-use/shape ?s] + [?u :token-use/token ?t]] + + ;; scope helper: shapes living on a page (component containers hold + ;; bookkeeping copies, ctf/load-component-objects) + [(on-page ?s) + [?s :shape/container ?c] + [?c :container/kind :page]]]) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; entity resolution +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn container-eid + [db container-id] + (d/entid db [:container/id container-id])) + +(defn shape-eid + "Resolve the (container, shape) pair to its entity id. + + An AVET lookup on `:shape/id` narrowed by container: the id alone is + not identity (`uuid/zero` keys every page's root frame)." + [db container-eid shape-id] + (some (fn [datom] + (let [e (:e datom)] + (when (= container-eid (:db/id (:shape/container (d/entity db e)))) + e))) + (d/datoms db :avet :shape/id shape-id))) + +(defn shape-eids + "Every entity carrying `shape-id`, across containers." + [db shape-id] + (mapv :e (d/datoms db :avet :shape/id shape-id))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the standing question set +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- entity-depth + [db eid] + (loop [e (d/entity db eid) n 0] + (if-let [p (:shape/parent e)] + (recur p (inc n)) + n))) + +(defn parent-heads + "Component heads that are ancestors of (container, shape), self + included, top-down: the overlay formulation of `ctn/get-parent-heads`. + + Adoption note: a caller holding the page objects should call the helper + directly; the pointer chain beats the rule walk by three orders of + magnitude. This exists for index-only callers and as the semantic pin + that the overlay's topology equals the document's." + [db container-id shape-id] + (let [heads (d/q '[:find [?a ...] + :in $ % ?cid ?sid + :where + [?c :container/id ?cid] + [?s :shape/container ?c] + [?s :shape/id ?sid] + (anc-or-self ?s ?a) + [?a :shape/component-id _]] + db rules container-id shape-id)] + (->> heads + (sort-by #(entity-depth db %)) + (mapv #(:shape/id (d/entity db %)))))) + +(defn instances-of + "Every instance head of (component, file) on any page, as + [page-id shape-id] pairs. + + The document-side equivalent is a full scan of every page's `:objects` + filtered by `ctk/instance-of?`; the overlay answers it from two AVET + lookups. Scoped to page containers because component records hold their + own copies of shapes." + [db component-id file-id] + (d/q '[:find ?pid ?id + :in $ ?cid ?fid + :where + [?e :shape/component-id ?cid] + [?e :shape/component-file ?fid] + [?e :shape/container ?c] + [?c :container/kind :page] + [?c :container/id ?pid] + [?e :shape/id ?id]] + db component-id file-id)) + +(defn descendant-ids + "Descendant shape ids of (container, shape), self excluded: the overlay + formulation of `cfh/get-children-ids`, as a set (z-order is the + document's business; the index answers membership)." + [db container-id shape-id] + (set (d/q '[:find [?id ...] + :in $ % ?cid ?sid + :where + [?c :container/id ?cid] + [?s :shape/container ?c] + [?s :shape/id ?sid] + (desc ?s ?d) + [?d :shape/id ?id]] + db rules container-id shape-id))) + +(defn descendant-ids-of-type + "Descendants of (container, shape) whose `:shape/type` is `type`: the + composition the report names as the overlay's advantage — a predicate + is one more clause, not one more function." + [db container-id shape-id type] + (set (d/q '[:find [?id ...] + :in $ % ?cid ?sid ?type + :where + [?c :container/id ?cid] + [?s :shape/container ?c] + [?s :shape/id ?sid] + (desc ?s ?d) + [?d :shape/type ?type] + [?d :shape/id ?id]] + db rules container-id shape-id type))) + +(defn shapes-by-name + "Shapes named exactly `name`, as [container-id shape-id] pairs, from + one AVET lookup." + [db name] + (d/q '[:find ?cid ?id + :in $ ?name + :where + [?s :shape/name ?name] + [?s :shape/container ?c] + [?c :container/id ?cid] + [?s :shape/id ?id]] + db name)) + +(defn instance-heads + "Every instance head on any page, as [page-id shape-id] pairs + (`ctk/instance-head?` over the whole document)." + [db] + (d/q '[:find ?pid ?id + :where + [?s :shape/component-id _] + [?s :shape/container ?c] + [?c :container/kind :page] + [?c :container/id ?pid] + [?s :shape/id ?id]] + db)) + +(defn shapes-using-color + "Shapes referencing library color `color-id`, as [container-id shape-id] + pairs (the LinkUsedColors question)." + [db color-id] + (d/q '[:find ?cid ?id + :in $ % ?colid + :where + [?col :color/id ?colid] + (uses-color ?s ?col) + [?s :shape/container ?c] + [?c :container/id ?cid] + [?s :shape/id ?id]] + db rules color-id)) + +(defn shapes-using-typography + "Shapes referencing `typography-id`, as [container-id shape-id] pairs + (the LinkUsedTypographies question)." + [db typography-id] + (d/q '[:find ?cid ?id + :in $ ?tid + :where + [?t :typography/id ?tid] + [?s :shape/uses-typography ?t] + [?s :shape/container ?c] + [?c :container/id ?cid] + [?s :shape/id ?id]] + db typography-id)) + +(defn shapes-using-token + "Applied-token uses of the token named `token-name`, as + [container-id shape-id property] triples (the LinkAppliedTokens + question)." + [db token-name] + (d/q '[:find ?cid ?id ?prop + :in $ ?name + :where + [?t :token/name ?name] + [?u :token-use/token ?t] + [?u :token-use/prop ?prop] + [?u :token-use/shape ?s] + [?s :shape/container ?c] + [?c :container/id ?cid] + [?s :shape/id ?id]] + db token-name)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; inventory and parity +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- attr-count + [db attr] + (count (d/datoms db :avet attr))) + +(defn stats + "Entity and edge inventory of the overlay." + [db] + {:datoms (count db) + :documents (attr-count db :document/id) + :containers (attr-count db :container/id) + :shapes (attr-count db :shape/id) + :components (attr-count db :component/id) + :colors (attr-count db :color/id) + :typographies (attr-count db :typography/id) + :token-sets (attr-count db :token-set/id) + :tokens (attr-count db :token/id) + :token-uses (attr-count db :token-use/shape)}) + +(defn edge-counts + "Count of every edge kind under the overlay's own conventions (all + containers, deleted components included where a rule does not exclude + them)." + [db] + {:is-child-of (+ (attr-count db :shape/parent) + (attr-count db :container/document) + (attr-count db :component/document)) + :is-instance-of (count (d/q '[:find ?s ?c :in $ % :where (is-instance-of ?s ?c)] + db rules)) + :refers-to (count (d/q '[:find ?s ?t :in $ % :where (refers-to ?s ?t)] + db rules)) + :fills-swap-slot (count (d/q '[:find ?s ?t :in $ % :where (fills-swap-slot ?s ?t)] + db rules)) + :uses-color (+ (attr-count db :shape/fill-color) + (attr-count db :shape/stroke-color) + (attr-count db :shape/text-color)) + :uses-typography (attr-count db :shape/uses-typography) + :uses-token (attr-count db :token-use/shape)}) + +(defn ladybug-parity-counts + "Edge counts under the Ladybug projection's own conventions, for the + roadmap's structure check: page shapes only (component containers are + an overlay extension), root frames excluded (the projection skips + them), live components only. + + A count that disagrees with the projection's relation table is a + finding to explain in writing, never to average away: the two likely + causes are a porting bug here and a projection limitation there, and + they demand opposite responses." + [db] + (let [zero uuid/zero + page-shapes (d/q '[:find [?s ...] + :in $ ?zero + :where + [?s :shape/container ?c] + [?c :container/kind :page] + (not [?s :shape/id ?zero])] + db zero) + pages (count (d/q '[:find [?c ...] + :where [?c :container/kind :page]] + db)) + live-comps (count (d/q '[:find [?c ...] + :where + [?c :component/id _] + (not [?c :component/deleted true])] + db))] + {:is-child-of (+ (count page-shapes) pages live-comps) + :is-instance-of (count (d/q '[:find ?s ?c + :in $ % + :where + (on-page ?s) + (is-instance-of ?s ?c)] + db rules)) + :refers-to (count (d/q '[:find ?s ?t + :in $ % + :where + (on-page ?s) + (refers-to ?s ?t) + (on-page ?t)] + db rules)) + :fills-swap-slot (count (d/q '[:find ?s ?t + :in $ % + :where + (on-page ?s) + (fills-swap-slot ?s ?t) + (on-page ?t)] + db rules))})) + +(defn component-main-instances + "[component-id main-instance-page main-instance-id] for every live + component that declares a main instance (the beadpot main-instance + linkage claim)." + [db] + (d/q '[:find ?id ?pid ?mid + :where + [?c :component/id ?id] + [?c :component/main-instance-page ?pid] + [?c :component/main-instance-id ?mid] + (not [?c :component/deleted true])] + db)) diff --git a/backend/src/app/graph/overlay/sync.clj b/backend/src/app/graph/overlay/sync.clj new file mode 100644 index 0000000000..7756e008e4 --- /dev/null +++ b/backend/src/app/graph/overlay/sync.clj @@ -0,0 +1,454 @@ +;; 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 app.graph.overlay.sync + "Incremental overlay updates from Penpot change vectors. + + The invariant this namespace defends: an overlay maintained from change + vectors equals an overlay rebuilt from the changed document. The change + semantics are `app.common.files.changes/process-change`'s, mirrored + clause by clause and cited per function; where a change touches state + the overlay does not index (geometry, style payloads), the mirror is a + no-op by design. + + Everything here is pure: db value in, db value out. The session layer + owns the atom and the revision bookkeeping." + (:require + [app.common.types.component :as ctk] + [app.common.types.page :as ctp] + [app.common.uuid :as uuid] + [app.graph.overlay :as overlay] + [app.graph.overlay.queries :as queries] + [datascript.core :as d])) + +(def supported-change-types + #{:add-obj :mod-obj :del-obj :mov-objects + :add-page :del-page :mod-page + :add-component :mod-component :del-component + :restore-component :purge-component}) + +(defn supported-change? + [change] + (contains? supported-change-types (:type change))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; resolution against the live db +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- doc-eid + [db] + (some-> (first (d/datoms db :avet :document/id)) :e)) + +(defn- sync-asset-ctx + "The `asset-ctx` of `app.graph.overlay`, resolved against the live db: + values are eids rather than tempids." + [db] + {:colors (into {} (map (fn [dtm] [(:v dtm) (:e dtm)])) + (d/datoms db :avet :color/id)) + :typographies (into {} (map (fn [dtm] [(:v dtm) (:e dtm)])) + (d/datoms db :avet :typography/id)) + :tokens-by-name (reduce (fn [acc dtm] + (update acc (:v dtm) (fnil conj []) (:e dtm))) + {} + (d/datoms db :avet :token/name))}) + +(defn- change-container-id + [{:keys [page-id component-id]}] + (or page-id component-id)) + +(defn- token-use-eids + [db shape-eid] + (mapv :e (d/datoms db :avet :token-use/shape shape-eid))) + +(defn- retract-shape-tx + "Retract one shape entity plus its applied-token relation entities + (`:db.fn/retractEntity` clears datoms pointing at the shape, but the + relation entity itself would survive as garbage)." + [db eid] + (into [[:db.fn/retractEntity eid]] + (map (fn [tu] [:db.fn/retractEntity tu])) + (token-use-eids db eid))) + +(defn- child-eids + [db eid] + (mapv :e (d/datoms db :avet :shape/parent eid))) + +(defn- subtree-eids + "The shape entity plus every descendant, via the reverse parent index." + [db root-eid] + (loop [acc [] + frontier [root-eid]] + (if-let [eid (peek frontier)] + (recur (conj acc eid) + (into (pop frontier) (child-eids db eid))) + acc))) + +(defn- container-shape-eids + [db container-eid] + (mapv :e (d/datoms db :avet :shape/container container-eid))) + +(defn- retract-container-shapes-tx + [db container-eid] + (into [] + (mapcat #(retract-shape-tx db %)) + (container-shape-eids db container-eid))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; per-change application +;; +;; Each function returns {:db db :applied? bool :reason kw?}. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- ok + [db] + {:db db :applied? true}) + +(defn- skip + [db reason] + {:db db :applied? false :reason reason}) + +(defn- apply-add-obj + "Mirror of `process-change :add-obj` -> `ctst/add-shape`: the effective + parent is `(or parent-id frame-id)`, falling back to the root frame + when absent from the container, then to the container itself." + [db {:keys [id obj frame-id parent-id] :as change}] + (let [container-id (change-container-id change) + ceid (queries/container-eid db container-id)] + (if-not ceid + (skip db :missing-container) + (let [pid (or parent-id frame-id) + peid (or (when (and pid (not= pid id)) + (queries/shape-eid db ceid pid)) + (queries/shape-eid db ceid uuid/zero) + ceid) + ctx (sync-asset-ctx db) + shape (assoc obj :id id) + tempid (overlay/shape-tempid container-id id) + existing (queries/shape-eid db ceid id) + tx (-> (if existing (retract-shape-tx db existing) []) + (conj (merge {:db/id tempid + :shape/id id + :shape/container ceid + :shape/parent peid} + (overlay/shape-attrs shape) + (overlay/shape-asset-attrs shape ctx))) + (into (overlay/token-use-entities + tempid (:applied-tokens shape) + (:tokens-by-name ctx))))] + (ok (d/db-with db tx)))))) + +(def ^:private plain-attr->overlay + {:name :shape/name + :component-id :shape/component-id + :component-file :shape/component-file + :shape-ref :shape/shape-ref}) + +(defn- replace-attr-tx + [eid attr val] + (if (some? val) + [[:db/add eid attr val]] + [[:db.fn/retractAttribute eid attr]])) + +(defn- replace-many-tx + [eid attr refs] + (into [[:db.fn/retractAttribute eid attr]] + (map (fn [r] [:db/add eid attr r])) + refs)) + +(defn- swap-slot-tx + "Mirror of `process-operation :set-touched`: `touched` only sticks on a + shape inside a component copy, and the overlay only indexes the swap + slot `ctk/get-swap-slot` extracts from it." + [db eid touched] + (let [in-copy? (some? (:shape/shape-ref (d/entity db eid))) + slot (when (and in-copy? (seq touched)) + (ctk/get-swap-slot {:touched touched}))] + (replace-attr-tx eid :shape/swap-slot slot))) + +(defn- set-op-tx + "Transaction data for one `:set` / `:set-touched` operation on `eid`. + Attributes the overlay does not index yield nil (a designed no-op), + mirroring `ctn/set-shape-attr` only for the indexed slice." + [db eid ctx {:keys [type attr val touched]}] + (cond + (= :set-touched type) + (swap-slot-tx db eid touched) + + (not= :set type) + nil + + (contains? plain-attr->overlay attr) + (replace-attr-tx eid (plain-attr->overlay attr) val) + + (= :touched attr) + (swap-slot-tx db eid val) + + (= :fills attr) + (replace-many-tx eid :shape/fill-color + (keep (:colors ctx) (overlay/fill-color-ref-ids val))) + + (= :strokes attr) + (replace-many-tx eid :shape/stroke-color + (keep (:colors ctx) (overlay/stroke-color-ref-ids val))) + + (= :content attr) + (concat (replace-many-tx eid :shape/text-color + (keep (:colors ctx) (overlay/content-color-ref-ids val))) + (replace-many-tx eid :shape/uses-typography + (keep (:typographies ctx) + (overlay/content-typography-ref-ids val)))) + + (= :applied-tokens attr) + (into (mapv (fn [tu] [:db.fn/retractEntity tu]) (token-use-eids db eid)) + (overlay/token-use-entities eid val (:tokens-by-name ctx))) + + :else nil)) + +(defn- apply-mod-obj + [db {:keys [id operations] :as change}] + (let [ceid (queries/container-eid db (change-container-id change)) + eid (when ceid (queries/shape-eid db ceid id))] + (if-not eid + (skip db :missing-shape) + (let [ctx (sync-asset-ctx db) + tx (into [] (mapcat #(set-op-tx db eid ctx %)) operations)] + (ok (cond-> db (seq tx) (d/db-with tx))))))) + +(defn- apply-del-obj + [db {:keys [id] :as change}] + (let [ceid (queries/container-eid db (change-container-id change)) + eid (when ceid (queries/shape-eid db ceid id))] + (if-not eid + ;; Penpot emits one :del-obj per selected shape, so a parent's + ;; deletion may already have removed this node; not a defect. + (ok db) + (ok (d/db-with db (into [] + (mapcat #(retract-shape-tx db %)) + (subtree-eids db eid))))))) + +(defn- apply-mov-objects + "Reparenting only: `:mov-objects` carries shape ids and a parent id and + nothing else (`common/src/app/common/files/changes.cljc`), and the + overlay stores no sibling order, so the whole change is one + `:shape/parent` re-point per moved shape." + [db {:keys [parent-id shapes] :as change}] + (let [ceid (queries/container-eid db (change-container-id change)) + peid (when ceid (queries/shape-eid db ceid parent-id))] + (if-not peid + (skip db :missing-parent) + (let [tx (into [] + (keep (fn [sid] + (when-let [eid (queries/shape-eid db ceid sid)] + [:db/add eid :shape/parent peid]))) + shapes)] + (ok (cond-> db (seq tx) (d/db-with tx))))))) + +(defn- apply-add-page + "Mirror of `process-change :add-page`: id+name means a fresh empty page + (`ctp/make-empty-page`), otherwise the provided page map." + [db {:keys [id name page]}] + (let [page (if (and (string? name) (uuid? id)) + (ctp/make-empty-page {:id id :name name}) + page) + page-id (:id page)] + (if (queries/container-eid db page-id) + (ok db) + (let [ctx (sync-asset-ctx db) + tid (overlay/container-tempid page-id) + tx (into [(cond-> {:db/id tid + :container/id page-id + :container/kind :page + :container/document (doc-eid db)} + (some? (:name page)) + (assoc :container/name (:name page)))] + (overlay/container-entities tid page-id (:objects page) ctx))] + (ok (d/db-with db tx)))))) + +(defn- apply-del-page + [db {:keys [id]}] + (if-let [ceid (queries/container-eid db id)] + (ok (d/db-with db (conj (retract-container-shapes-tx db ceid) + [:db.fn/retractEntity ceid]))) + (skip db :missing-page))) + +(defn- apply-mod-page + [db {:keys [id name]}] + (let [ceid (queries/container-eid db id)] + (cond + (nil? ceid) (skip db :missing-page) + (not (string? name)) (ok db) + :else (ok (d/db-with db [[:db/add ceid :container/name name]]))))) + +(defn- component-attrs-tx + [eid {:keys [name main-instance-id main-instance-page]}] + (cond-> [] + (some? name) (conj [:db/add eid :component/name name]) + (some? main-instance-id) (conj [:db/add eid :component/main-instance-id main-instance-id]) + (some? main-instance-page) (conj [:db/add eid :component/main-instance-page main-instance-page]))) + +(defn- apply-add-component + "Mirror of `ctkl/add-component`; objects never ride an add." + [db {:keys [id] :as change}] + (if (d/entid db [:component/id id]) + (ok db) + (let [tx (into [{:db/id -1 :component/id id :component/document (doc-eid db)}] + (component-attrs-tx -1 change))] + (ok (d/db-with db tx))))) + +(defn- clear-component-container-tx + "Drop a component's own shape copies and its container role, keeping the + component record (mirror of the `dissoc :objects` in + `ctkl/mod-component` and `ctf/restore-component`)." + [db eid] + (into (retract-container-shapes-tx db eid) + [[:db.fn/retractAttribute eid :container/id] + [:db.fn/retractAttribute eid :container/kind] + [:db.fn/retractAttribute eid :container/document]])) + +(defn- component-container-tx + "Give the component entity a container role over `objects`." + [db eid component-id objects] + (let [ctx (sync-asset-ctx db)] + (into [[:db/add eid :container/id component-id] + [:db/add eid :container/kind :component] + [:db/add eid :container/document (doc-eid db)]] + (overlay/container-entities eid component-id objects ctx)))) + +(defn- apply-mod-component + "Mirror of `ctkl/mod-component`, including its sharpest edge: a + `:mod-component` without `:objects` dissocs the component's own copy, + so the overlay drops the component container either way and rebuilds it + only when the change carries objects." + [db {:keys [id objects] :as change}] + (if-let [eid (d/entid db [:component/id id])] + (let [tx (-> (component-attrs-tx eid change) + (into (clear-component-container-tx db eid)) + (cond-> (some? objects) + (into (component-container-tx db eid id objects))))] + (ok (cond-> db (seq tx) (d/db-with tx)))) + (skip db :missing-component))) + +(defn- entity-shape-attrs + "The indexed attrs of a live shape entity, as assertable values (asset + references flattened to eids)." + [ent] + (let [many-ids #(into [] (map :db/id) %)] + (cond-> {:shape/type (:shape/type ent)} + (some? (:shape/name ent)) (assoc :shape/name (:shape/name ent)) + (some? (:shape/component-id ent)) (assoc :shape/component-id (:shape/component-id ent)) + (some? (:shape/component-file ent)) (assoc :shape/component-file (:shape/component-file ent)) + (some? (:shape/shape-ref ent)) (assoc :shape/shape-ref (:shape/shape-ref ent)) + (some? (:shape/swap-slot ent)) (assoc :shape/swap-slot (:shape/swap-slot ent)) + (seq (:shape/fill-color ent)) (assoc :shape/fill-color (many-ids (:shape/fill-color ent))) + (seq (:shape/stroke-color ent)) (assoc :shape/stroke-color (many-ids (:shape/stroke-color ent))) + (seq (:shape/text-color ent)) (assoc :shape/text-color (many-ids (:shape/text-color ent))) + (seq (:shape/uses-typography ent)) (assoc :shape/uses-typography (many-ids (:shape/uses-typography ent)))))) + +(defn- snapshot-component-tx + "Mirror of `ctf/load-component-objects`: copy the main-instance subtree + from its page into the component's own container, same ids, new + (container, shape) entities. The copy is taken from the overlay itself, + which is exactly the identity/type/topology slice the rebuild would + project from the document's copy. Geometry (`delta`) is not indexed, so + the move that accompanies an undo of cut-paste is a designed no-op." + [db comp-eid] + (let [ent (d/entity db comp-eid) + comp-id (:component/id ent) + mid (:component/main-instance-id ent) + mpg (:component/main-instance-page ent) + pceid (when mpg (queries/container-eid db mpg)) + root (when (and pceid mid) (queries/shape-eid db pceid mid))] + (when (and root (empty? (container-shape-eids db comp-eid))) + (let [eids (subtree-eids db root) + eidset (set eids) + copy-tempid (fn [eid] + (overlay/shape-tempid comp-id (:shape/id (d/entity db eid))))] + (into [[:db/add comp-eid :container/id comp-id] + [:db/add comp-eid :container/kind :component] + [:db/add comp-eid :container/document (doc-eid db)]] + (mapcat (fn [eid] + (let [src (d/entity db eid) + tempid (copy-tempid eid) + parent (:db/id (:shape/parent src)) + copy (merge {:db/id tempid + :shape/id (:shape/id src) + :shape/container comp-eid + :shape/parent (if (contains? eidset parent) + (copy-tempid parent) + comp-eid)} + (entity-shape-attrs src)) + uses (for [tu (token-use-eids db eid)] + (let [tue (d/entity db tu)] + {:token-use/shape tempid + :token-use/token (:db/id (:token-use/token tue)) + :token-use/prop (:token-use/prop tue)}))] + (cons copy uses)))) + eids))))) + +(defn- apply-del-component + "Mirror of `ctf/delete-component`: with `skip-undelete?` the component + goes entirely; otherwise it is marked deleted and keeps its own copy of + the main-instance subtree." + [db {:keys [id skip-undelete?]}] + (if-let [eid (d/entid db [:component/id id])] + (if skip-undelete? + (ok (d/db-with db (conj (retract-container-shapes-tx db eid) + [:db.fn/retractEntity eid]))) + (ok (d/db-with db (into [[:db/add eid :component/deleted true]] + (snapshot-component-tx db eid))))) + (ok db))) + +(defn- apply-restore-component + "Mirror of `ctf/restore-component`: undelete, drop the component's own + copy, optionally repoint the main-instance page." + [db {:keys [id page-id]}] + (if-let [eid (d/entid db [:component/id id])] + (let [tx (cond-> (into [[:db.fn/retractAttribute eid :component/deleted]] + (clear-component-container-tx db eid)) + (some? page-id) + (conj [:db/add eid :component/main-instance-page page-id]))] + (ok (d/db-with db tx))) + (skip db :missing-component))) + +(defn- apply-purge-component + [db {:keys [id]}] + (if-let [eid (d/entid db [:component/id id])] + (ok (d/db-with db (conj (retract-container-shapes-tx db eid) + [:db.fn/retractEntity eid]))) + (ok db))) + +(defn- apply-change + [db change] + (case (:type change) + :add-obj (apply-add-obj db change) + :mod-obj (apply-mod-obj db change) + :del-obj (apply-del-obj db change) + :mov-objects (apply-mov-objects db change) + :add-page (apply-add-page db change) + :del-page (apply-del-page db change) + :mod-page (apply-mod-page db change) + :add-component (apply-add-component db change) + :mod-component (apply-mod-component db change) + :del-component (apply-del-component db change) + :restore-component (apply-restore-component db change) + :purge-component (apply-purge-component db change) + (skip db :unsupported-type))) + +(defn apply-changes + "Apply Penpot `changes` to overlay `db`. Pure. + + Returns `{:db db' :applied [types...] :skipped [{:type .. :reason ..}]}`." + [db changes] + (reduce (fn [acc change] + (let [{:keys [db applied? reason]} (apply-change (:db acc) change)] + (-> acc + (assoc :db db) + (cond-> + applied? (update :applied conj (:type change)) + (not applied?) (update :skipped conj {:type (:type change) + :reason reason}))))) + {:db db :applied [] :skipped []} + changes)) diff --git a/backend/test/backend_tests/graph_overlay_console_test.clj b/backend/test/backend_tests/graph_overlay_console_test.clj new file mode 100644 index 0000000000..f0203e1fb1 --- /dev/null +++ b/backend/test/backend_tests/graph_overlay_console_test.clj @@ -0,0 +1,120 @@ +;; 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 backend-tests.graph-overlay-console-test + "Pure tests over the console's parse-gate-run pipeline + (`app.graph.overlay.console/run-query`) and the default query it ships + (`app.graph.debug/default-query`). + + The gate exists so the console cannot run arbitrary Clojure; these + tests hold it shut against namespace-qualified functions and unknown + bare symbols, and hold it open for the shared rules, datascript + built-ins, and aggregates. No session, no msgbus: one overlay built + from a test-helper file and one function call per case." + (:require + [app.common.features :as ffeat] + [app.common.test-helpers.components :as thc] + [app.common.test-helpers.files :as thf] + [app.common.test-helpers.ids-map :as thi] + [app.common.test-helpers.shapes :as ths] + [app.graph.debug :as debug] + [app.graph.overlay :as overlay] + [app.graph.overlay.console :as console] + [clojure.string :as str] + [clojure.test :as t] + [datascript.core :as d])) + +(t/use-fixtures :each thi/test-fixture) + +(defn- fixture-db + "One overlay of a file with one component and one instance of it, plus + enough named shapes that the row-cap test has rows to cap." + [] + (binding [ffeat/*current* #{"components/v2"}] + (let [file (-> (thf/sample-file "console fixture") + (ths/add-sample-shape "main" :type :frame :name "Main") + (ths/add-sample-shape "child-a" :type :rect :name "Child A" + :parent-label "main") + (ths/add-sample-shape "child-b" :type :circle :name "Child B" + :parent-label "main") + (thc/make-component "comp" "main") + (thc/instantiate-component "comp" "copy"))] + (overlay/build (:data file) file)))) + +(defn- thrown-data + "The ex-data of the ExceptionInfo `body` throws, or nil when it does + not throw." + [body] + (try + (body) + nil + (catch clojure.lang.ExceptionInfo e + (ex-data e)))) + +(t/deftest the-gate-rejects-namespace-qualified-functions + (let [data (thrown-data + #(console/run-query + (fixture-db) + "[:find ?v :where [(clojure.core/eval (quote (+ 1 1))) ?v]]"))] + (t/is (some? data) "the gate must throw") + (t/is (= :graph-query-not-read-only (:code data))) + (t/is (str/includes? (:hint data) "clojure.core/eval") + "the error must name the offending symbol"))) + +(t/deftest the-gate-rejects-unknown-bare-symbols + (let [data (thrown-data + #(console/run-query + (fixture-db) + "[:find ?v :where [?e :shape/id ?v] [(slurpish ?v)]]"))] + (t/is (= :graph-query-not-read-only (:code data))) + (t/is (str/includes? (:hint data) "slurpish") + "the error must name the offending symbol"))) + +(t/deftest unreadable-text-is-a-parse-error + (let [data (thrown-data + #(console/run-query (fixture-db) "[:find ?v :where"))] + (t/is (= :graph-query-invalid (:code data))))) + +(t/deftest the-default-query-runs-through-the-console + ;; The shipped default invokes the shared `is-instance-of` rule with + ;; `%`; a rule invocation must pass the gate and return rows. + (let [{:keys [columns rows truncated? row-count]} + (console/run-query (fixture-db) debug/default-query)] + (t/is (= ["component" "instance" "page" "filter_src_id" "filter_tgt_id"] + columns)) + (t/is (pos? row-count)) + (t/is (false? truncated?)) + (t/is (every? (fn [row] + (every? #(re-matches #"\d+" (str %)) (subvec row 3))) + rows) + "the filter columns must carry node eids, rendered as decimal strings"))) + +(t/deftest scalar-and-collection-finds-normalize-to-rows + (let [scalar (console/run-query (fixture-db) + "[:find ?n . :where [?e :shape/name ?n]]") + coll (console/run-query (fixture-db) + "[:find [?n ...] :where [?e :shape/name ?n]]")] + (t/is (= ["n"] (:columns scalar))) + (t/is (= 1 (count (:rows scalar)))) + (t/is (= 1 (count (first (:rows scalar))))) + (t/is (= 1 (count (:columns coll)))) + (t/is (pos? (count (:rows coll)))) + (t/is (every? #(= 1 (count %)) (:rows coll))))) + +(t/deftest the-row-cap-truncates-and-says-so + (let [{:keys [rows truncated? row-count]} + (with-redefs [console/max-rows 3] + (console/run-query (fixture-db) "[:find ?n :where [?e :shape/name ?n]]"))] + (t/is (true? truncated?)) + (t/is (= 3 row-count)) + (t/is (= 3 (count rows))))) + +(t/deftest aggregates-are-allowed + (let [db (fixture-db) + expected (count (d/datoms db :avet :shape/id)) + {:keys [rows]} (console/run-query db + "[:find (count ?s) :where [?s :shape/id _]]")] + (t/is (= [[expected]] rows)))) diff --git a/backend/test/backend_tests/graph_overlay_sync_test.clj b/backend/test/backend_tests/graph_overlay_sync_test.clj new file mode 100644 index 0000000000..c71d50eaff --- /dev/null +++ b/backend/test/backend_tests/graph_overlay_sync_test.clj @@ -0,0 +1,471 @@ +;; This Source Code Form is subject to the terms of the Mozilla Public +;; License, v. 2.0. If a copy of the MPL was not distributed with this +;; file, You can obtain one at http://mozilla.org/MPL/2.0/. +;; +;; Copyright (c) KALEIDOS INC Sucursal en España SL + +(ns backend-tests.graph-overlay-sync-test + "Cold build and incremental sync are two implementations of one mapping, + and this namespace holds them to it. + + `app.graph.overlay/build` projects a whole file into a fresh overlay. + `app.graph.overlay.sync/apply-changes` replays the change vocabulary the + editor emits onto an overlay that is already open. The overlay the second + one maintains must equal the overlay the first one would build from the + changed document, or the console shows a graph no rebuild reproduces. + + The round trip: build the fixture file into A, apply a change list to A + and the same list to the file data, rebuild the result into B, and + compare A against B in an entity-id-independent normal form. + `app.common.files.changes/process-changes` is the document oracle. No + Ladybug, no Postgres, no session: two datascript database values and + pure functions." + (:require + [app.common.features :as ffeat] + [app.common.files.changes :as cp] + [app.common.test-helpers.shapes :as ths] + [app.common.types.file :as ctf] + [app.common.types.library :as ctl] + [app.common.types.tokens-lib :as ctob] + [app.common.uuid :as uuid] + [app.graph.overlay :as overlay] + [app.graph.overlay.sync :as sync] + [clojure.set :as set] + [clojure.test :as t] + [datascript.core :as d])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the fixture file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Fixed ids: a failure should read the same on every run. +(def ^:private file-id #uuid "00000000-0000-0000-0000-00000000f11e") +(def ^:private page-id #uuid "00000000-0000-0000-0000-0000000000a1") +(def ^:private page2-id #uuid "00000000-0000-0000-0000-0000000000a2") +(def ^:private frame-id #uuid "00000000-0000-0000-0000-0000000000f1") +(def ^:private rect-id #uuid "00000000-0000-0000-0000-0000000000b1") +(def ^:private circ-id #uuid "00000000-0000-0000-0000-0000000000b2") +(def ^:private text-id #uuid "00000000-0000-0000-0000-0000000000b3") +(def ^:private rect2-id #uuid "00000000-0000-0000-0000-0000000000b4") +(def ^:private subchild-id #uuid "00000000-0000-0000-0000-0000000000b5") +(def ^:private p2-shape-id #uuid "00000000-0000-0000-0000-0000000000b6") +(def ^:private comp-root-id #uuid "00000000-0000-0000-0000-0000000000c1") +(def ^:private comp-child-id #uuid "00000000-0000-0000-0000-0000000000c2") +(def ^:private copy-root-id #uuid "00000000-0000-0000-0000-0000000000c3") +(def ^:private copy-child-id #uuid "00000000-0000-0000-0000-0000000000c4") +(def ^:private comp-id #uuid "00000000-0000-0000-0000-0000000000e1") +(def ^:private color-id #uuid "00000000-0000-0000-0000-0000000000d1") +(def ^:private token-set-id #uuid "00000000-0000-0000-0000-0000000000d2") +(def ^:private token-id #uuid "00000000-0000-0000-0000-0000000000d3") +(def ^:private swap-slot-id #uuid "00000000-0000-0000-0000-000000005571") + +(defn- shape + "A valid shape for an `:add-obj` payload, from + `app.common.test-helpers.shapes/sample-shape`: `process-change :add-obj` + hard-validates on the JVM (`app.common.files.changes/validate-shape`), + and hand-rolled maps do not survive it." + [id type & {:as attrs}] + (ths/sample-shape nil (assoc attrs :id id :type type))) + +(defn- base-data + "The untouched document the change list mutates. The library colour and + the token live here, not in the change list, because the sync path does + not support `:add-color` or `:set-token*` changes: both paths must see + them from the start for the asset links to resolve." + [] + (binding [ffeat/*current* #{"components/v2"}] + (-> (ctf/make-file-data file-id page-id) + (ctl/add-color {:id color-id :name "Fixture green" + :color "#00FF00" :opacity 1}) + (assoc :tokens-lib + (-> (ctob/make-tokens-lib) + (ctob/add-set + (ctob/make-token-set + :id token-set-id + :name "Brand" + :tokens {"brand.primary" (ctob/make-token + :id token-id + :name "brand.primary" + :type :color + :value "#FF00FF")}))))))) + +(def ^:private swap-slot-kw + (keyword (str "swap-slot-" swap-slot-id))) + +(def ^:private changes + "One change of every type the sync path claims to support, in the order + an editing session would emit them, and every indexed attribute at least + once: topology (add, reparent, delete a subtree), the `:mod-obj` set ops + with their asset refs (`app.graph.overlay.sync/set-op-tx`), a touched + swap slot on a shape inside a copy (`ctk/get-swap-slot`), and the whole + component lifecycle from add to purge." + [{:type :add-obj :page-id page-id :id frame-id + :parent-id uuid/zero :frame-id uuid/zero + :obj (shape frame-id :frame {:name "Board" :width 400 :height 300})} + + {:type :add-obj :page-id page-id :id rect-id + :parent-id frame-id :frame-id frame-id + :obj (shape rect-id :rect {:name "Rect" :parent-id frame-id :frame-id frame-id + :width 100 :height 50})} + + {:type :add-obj :page-id page-id :id circ-id + :parent-id frame-id :frame-id frame-id + :obj (shape circ-id :circle {:name "Circle" :parent-id frame-id :frame-id frame-id + :width 40 :height 40})} + + ;; nested inside circ: the subtree :del-obj removes along with it + {:type :add-obj :page-id page-id :id subchild-id + :parent-id circ-id :frame-id frame-id + :obj (shape subchild-id :rect {:name "Sub child" :parent-id circ-id :frame-id frame-id + :width 10 :height 10})} + + {:type :add-obj :page-id page-id :id text-id + :parent-id frame-id :frame-id frame-id + :obj (shape text-id :text {:name "Label" :parent-id frame-id :frame-id frame-id})} + + {:type :add-obj :page-id page-id :id rect2-id + :parent-id frame-id :frame-id frame-id + :obj (shape rect2-id :rect {:name "Rect two" :parent-id frame-id :frame-id frame-id + :width 20 :height 20})} + + ;; a rename, plus two attributes whose values are falsy: `blocked false` + ;; and `opacity 0` are values, not absences, on both paths + {:type :mod-obj :page-id page-id :id rect-id + :operations [{:type :set :attr :name :val "Renamed rect"} + {:type :set :attr :blocked :val false} + {:type :set :attr :opacity :val 0}]} + + ;; a fill carrying a library colour ref: the overlay links it + {:type :mod-obj :page-id page-id :id rect2-id + :operations [{:type :set :attr :fills + :val [(assoc (ths/sample-fill-color :fill-color "#ABCDEF" :fill-opacity 1) + :fill-color-ref-id color-id)]}]} + + ;; an applied token: one token-use entity (shape, property, token) + {:type :mod-obj :page-id page-id :id rect2-id + :operations [{:type :set :attr :applied-tokens + :val {:fill "brand.primary"} + :ignore-touched true}]} + + ;; reorder inside the same container: the overlay stores no sibling + ;; order, so this must be invisible to it (and therefore is NOT the + ;; :mov-objects the injected-bug test drops) + {:type :mov-objects :page-id page-id :parent-id frame-id :index 0 :shapes [circ-id]} + + ;; reparent to the page's root frame: the parent edge must move + {:type :mov-objects :page-id page-id :parent-id uuid/zero :index 0 :shapes [text-id]} + + ;; delete with survivors: circ and its subtree go, the frame's other + ;; children stay + {:type :del-obj :page-id page-id :id circ-id} + + {:type :add-page :id page2-id :name "Page two"} + + {:type :add-obj :page-id page2-id :id p2-shape-id + :parent-id uuid/zero :frame-id uuid/zero + :obj (shape p2-shape-id :rect {:name "Page two shape" :width 50 :height 50})} + + {:type :mod-page :id page-id :name "Page one, renamed"} + + ;; the deleted page carries shapes: the whole container must go + {:type :del-page :id page2-id} + + ;; the main instance: root and child land on the page first, exactly + ;; as the editor's change builder emits them (`pcb/add-component`) + {:type :add-obj :page-id page-id :id comp-root-id + :parent-id uuid/zero :frame-id uuid/zero + :obj (shape comp-root-id :frame {:name "Main" :width 200 :height 200})} + + {:type :add-obj :page-id page-id :id comp-child-id + :parent-id comp-root-id :frame-id comp-root-id + :obj (shape comp-child-id :rect {:name "Main child" :parent-id comp-root-id + :frame-id comp-root-id :width 60 :height 40})} + + {:type :add-component :id comp-id :name "Fixture component" :path "Fixture component" + :main-instance-id comp-root-id :main-instance-page page-id} + + ;; the component membership ops the editor emits next to :add-component + {:type :mod-obj :page-id page-id :id comp-root-id + :operations [{:type :set :attr :component-id :val comp-id} + {:type :set :attr :component-file :val nil} + {:type :set :attr :component-root :val true} + {:type :set :attr :main-instance :val true} + {:type :set :attr :shape-ref :val nil}]} + + {:type :mod-obj :page-id page-id :id comp-child-id + :operations [{:type :set :attr :component-id :val comp-id} + {:type :set :attr :main-instance :val false}]} + + ;; a copy of the component on the same page: `shape-ref` marks the + ;; homologue, which is what makes `ctk/in-component-copy?` true + {:type :add-obj :page-id page-id :id copy-root-id + :parent-id uuid/zero :frame-id uuid/zero + :obj (shape copy-root-id :frame {:name "Copy" :parent-id uuid/zero :frame-id uuid/zero + :width 200 :height 200 + :shape-ref comp-root-id + :component-id comp-id + :component-root true})} + + {:type :add-obj :page-id page-id :id copy-child-id + :parent-id copy-root-id :frame-id copy-root-id + :obj (shape copy-child-id :rect {:name "Copy child" :parent-id copy-root-id + :frame-id copy-root-id :width 60 :height 40 + :shape-ref comp-child-id + :component-id comp-id})} + + ;; a swap slot on a shape inside the copy: only the slot is indexed, + ;; and only because `ctk/get-swap-slot` extracts it + {:type :mod-obj :page-id page-id :id copy-root-id + :operations [{:type :set-touched :touched #{swap-slot-kw}}]} + + {:type :mod-component :id comp-id :name "Fixture component, renamed"} + + ;; soft delete: the component keeps the main-instance subtree as its + ;; own container copy (`ctf/load-component-objects`), in the rebuilt + ;; overlay and the synced one alike + {:type :del-component :id comp-id} + + {:type :restore-component :id comp-id :page-id page-id} + + {:type :del-component :id comp-id} + + {:type :purge-component :id comp-id}]) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the normal form +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Entity ids are datascript internals that depend on insertion order, so +;; a parity check cannot compare them. The normal form keys every entity +;; by what identifies it in the document and replaces every reference +;; value with the target's key; cardinality-many refs become sets of +;; keys. The result is a set of [entity-key attr-map] pairs, and two +;; overlays are equal exactly when their normal forms are `=`. + +(defn- entity-key + "The document key of one entity: `[:document id]`, `[:container id]`, + `[:component id]`, `[:shape container-id shape-id]`, `[:color id]`, + `[:typography id]`, `[:token-set id]`, `[:token id]`, or + `[:token-use shape-key token-id prop]`." + [db eid] + (let [ent (d/entity db eid)] + (cond + (some? (:document/id ent)) + [:document (:document/id ent)] + + ;; a component entity may also carry a container role; the + ;; component key wins + (some? (:component/id ent)) + [:component (:component/id ent)] + + (some? (:container/id ent)) + [:container (:container/id ent)] + + (some? (:shape/id ent)) + [:shape (:container/id (:shape/container ent)) (:shape/id ent)] + + (some? (:color/id ent)) + [:color (:color/id ent)] + + (some? (:typography/id ent)) + [:typography (:typography/id ent)] + + (some? (:token-set/id ent)) + [:token-set (:token-set/id ent)] + + (some? (:token/id ent)) + [:token (:token/id ent)] + + (some? (:token-use/shape ent)) + (let [s (:token-use/shape ent) + t (:token-use/token ent)] + [:token-use + [:shape (:container/id (:shape/container s)) (:shape/id s)] + (:token/id t) + (:token-use/prop ent)])))) + +(defn- ref-key + [keymap ref] + (when-let [eid (:db/id ref)] + (get keymap eid))) + +(defn- ref-keys + [keymap refs] + (into #{} (map #(ref-key keymap %)) refs)) + +(defn- attr-map + "The indexed attributes of one entity with refs replaced by keys. + Identity attributes carried by the key itself are omitted. Attributes + the entity does not carry appear as nil, so a presence difference + between the two paths shows up instead of hiding." + [keymap ent] + (cond + (some? (:document/id ent)) + {:document/id (:document/id ent) + :document/name (:document/name ent)} + + (some? (:component/id ent)) + {:component/id (:component/id ent) + :component/name (:component/name ent) + :component/deleted (:component/deleted ent) + :component/main-instance-id (:component/main-instance-id ent) + :component/main-instance-page (:component/main-instance-page ent) + :component/document (ref-key keymap (:component/document ent)) + :container/id (:container/id ent) + :container/kind (:container/kind ent) + :container/name (:container/name ent) + :container/document (ref-key keymap (:container/document ent))} + + (some? (:container/id ent)) + {:container/id (:container/id ent) + :container/kind (:container/kind ent) + :container/name (:container/name ent) + :container/document (ref-key keymap (:container/document ent))} + + (some? (:shape/id ent)) + {:shape/type (:shape/type ent) + :shape/name (:shape/name ent) + :shape/component-id (:shape/component-id ent) + :shape/component-file (:shape/component-file ent) + :shape/shape-ref (:shape/shape-ref ent) + :shape/swap-slot (:shape/swap-slot ent) + :shape/parent (ref-key keymap (:shape/parent ent)) + :shape/fill-color (ref-keys keymap (:shape/fill-color ent)) + :shape/stroke-color (ref-keys keymap (:shape/stroke-color ent)) + :shape/text-color (ref-keys keymap (:shape/text-color ent)) + :shape/uses-typography (ref-keys keymap (:shape/uses-typography ent))} + + (some? (:color/id ent)) + {:color/id (:color/id ent) + :color/name (:color/name ent) + :color/document (ref-key keymap (:color/document ent))} + + (some? (:typography/id ent)) + {:typography/id (:typography/id ent) + :typography/name (:typography/name ent) + :typography/document (ref-key keymap (:typography/document ent))} + + (some? (:token-set/id ent)) + {:token-set/id (:token-set/id ent) + :token-set/name (:token-set/name ent) + :token-set/document (ref-key keymap (:token-set/document ent))} + + (some? (:token/id ent)) + {:token/id (:token/id ent) + :token/name (:token/name ent) + :token/type (:token/type ent) + :token/set (ref-key keymap (:token/set ent))} + + ;; a token-use entity: shape, token and property all live in the key + :else {})) + +(defn- normal-form + "The overlay as entity-id-independent data: a set of + [entity-key attr-map] pairs." + [db] + (let [keymap (into {} + (map (fn [eid] [eid (entity-key db eid)])) + (distinct (map :e (d/datoms db :eavt))))] + (into #{} (map (fn [[eid key]] [key (attr-map keymap (d/entity db eid))])) + keymap))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the round trip +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- round-trip + "Sync `change-list` into A, rebuild the changed document into B, return + the normal-form difference and the apply-changes report." + [change-list] + (let [data0 (base-data) + data1 (cp/process-changes data0 change-list false) + result (sync/apply-changes (overlay/build data0) change-list) + synced (normal-form (:db result)) + rebuilt (normal-form (overlay/build data1))] + {:diff (set/union (set/difference synced rebuilt) + (set/difference rebuilt synced)) + :applied (:applied result) + :skipped (:skipped result)})) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest the-fixture-exercises-every-supported-change-type + (t/is (= sync/supported-change-types (set (map :type changes))))) + +(t/deftest every-change-in-the-list-is-applied + (let [{:keys [applied skipped]} (round-trip changes)] + (t/is (empty? skipped) + (str "the fixture must exercise the sync path, not the skip path: " + (pr-str skipped))) + (t/is (= (map :type changes) applied)))) + +(t/deftest synced-graph-equals-rebuilt-graph + (let [{:keys [diff]} (round-trip changes)] + (t/is (empty? diff) + (str "synced and rebuilt overlays disagree on " (pr-str diff))))) + +(t/deftest every-prefix-stays-in-sync + ;; The end state can agree while a middle state does not (an ordering + ;; bug). Replay every prefix of the list and hold both paths equal at + ;; every step. + (let [data0 (base-data)] + (doseq [n (range (inc (count changes)))] + (let [prefix (subvec changes 0 n) + result (sync/apply-changes (overlay/build data0) prefix) + synced (normal-form (:db result)) + rebuilt (normal-form (overlay/build (cp/process-changes data0 prefix false)))] + (t/is (and (empty? (:skipped result)) + (= synced rebuilt)) + (str "prefix of length " n " diverges; skipped " + (pr-str (:skipped result)))))))) + +(t/deftest soft-delete-keeps-the-component-container-copy + ;; `ctf/delete-component` without `skip-undelete?` stores the + ;; main-instance subtree on the component (`ctf/load-component-objects`); + ;; the overlay mirrors it as a component container, on both paths. + (let [first-del (first (keep-indexed + (fn [i ch] (when (= :del-component (:type ch)) i)) + changes)) + prefix (subvec changes 0 (inc first-del)) + data0 (base-data) + result (sync/apply-changes (overlay/build data0) prefix) + rebuilt (overlay/build (cp/process-changes data0 prefix false))] + (doseq [form [(normal-form (:db result)) (normal-form rebuilt)]] + (let [keys (into #{} (map first) form)] + (t/is (contains? keys [:shape comp-id comp-root-id]) + "the component container must hold the main-instance root copy") + (t/is (contains? keys [:shape comp-id comp-child-id]) + "the component container must hold the main-instance child copy") + (t/is (contains? form + [[:component comp-id] + {:component/id comp-id + :component/name "Fixture component, renamed" + :component/deleted true + :component/main-instance-id comp-root-id + :component/main-instance-page page-id + :component/document [:document file-id] + :container/id comp-id + :container/kind :component + :container/name nil + :container/document [:document file-id]}])))))) + +(t/deftest the-diff-catches-an-injected-sync-bug + ;; The round trip is only worth running if it fails when sync is wrong. + ;; Drop the reparenting :mov-objects from the list the overlay sees, + ;; keep it in the list the document sees, and the moved shape's entity + ;; key must appear in the difference: the check is locatable, not just + ;; boolean. + (let [data0 (base-data) + data1 (cp/process-changes data0 changes false) + crippled (remove #(and (= :mov-objects (:type %)) + (some #{text-id} (:shapes %))) + changes) + synced (normal-form (:db (sync/apply-changes (overlay/build data0) crippled))) + rebuilt (normal-form (overlay/build data1)) + diff (set/union (set/difference synced rebuilt) + (set/difference rebuilt synced)) + moved (into #{} (map first) diff)] + (t/is (contains? moved [:shape page-id text-id]) + "a sync that skips a reparent must name the moved shape's key"))) diff --git a/backend/test/backend_tests/graph_overlay_test.clj b/backend/test/backend_tests/graph_overlay_test.clj new file mode 100644 index 0000000000..52d333767a --- /dev/null +++ b/backend/test/backend_tests/graph_overlay_test.clj @@ -0,0 +1,699 @@ +;; 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 backend-tests.graph-overlay-test + "The semantic suite of the datascript graph overlay: the beadpot graph + test suite (beadpot:tests/graph/transform) ported from Cypher to + Datalog, one fixture file. + + Every deftest names the beadpot test it ports and the Penpot helper + that is the correctness oracle. A backported assertion that disagrees + with a helper is a beadpot bug: the helper's answer is asserted and the + divergence is noted in the docstring. Beadpot's idempotency tests have + no port here: `app.graph.overlay/build` is a pure function of the + document, so linking twice cannot duplicate an edge by construction. + + The fixture is built exclusively with the common test helpers + (`app.common.test-helpers.*`), so it stays a legal file + (`thf/validate-file!` runs before the overlay is built)." + (:require + [app.common.files.helpers :as cfh] + [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.test-helpers.tokens :as tht] + [app.common.types.component :as ctk] + [app.common.types.components-list :as ctkl] + [app.common.types.container :as ctn] + [app.common.types.shape :as cts] + [app.common.types.text :as txt] + [app.common.types.tokens-lib :as ctob] + [app.common.uuid :as uuid] + [app.graph.overlay :as overlay] + [app.graph.overlay.queries :as queries] + [clojure.test :as t] + [datascript.core :as d])) + +(t/use-fixtures :each thi/test-fixture) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; the fixture file +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- sample-fill + "A fill carrying a library color reference." + [color-id] + {:fill-color "#000000" + :fill-opacity 1 + :fill-color-ref-id color-id}) + +(defn- sample-stroke + "A stroke carrying a library color reference." + [color-id] + {:stroke-style :solid + :stroke-alignment :inner + :stroke-width 1 + :stroke-color "#000000" + :stroke-opacity 1 + :stroke-color-ref-id color-id}) + +(defn- refs-content + "Text content whose text nodes carry `:typography-ref-id` and, when + `color-id` is given, a fill referencing it. Only text nodes are touched: + the content schema forbids these attributes on the root and + paragraph-set nodes." + [text typography-id color-id] + (let [content (txt/change-text nil text)] + (txt/transform-nodes + txt/is-text-node? + (fn [node] + (cond-> (assoc node :typography-ref-id typography-id) + (some? color-id) + (assoc :fills [(sample-fill color-id)]))) + content))) + +(defn- refs-text-shape + "A text shape whose content nodes carry the given references." + [typography-id color-id] + (-> (cts/setup-shape {:type :text :x 0 :y 0}) + (assoc :content (refs-content "Typography sample" typography-id color-id) + :position-data nil))) + +(defn- document-containers + "Every [container-id objects] pair the overlay indexes: the pages, plus + the `:objects` snapshot a deleted component carries + (`app.common.types.file/load-component-objects`)." + [data] + (concat (map (fn [page] [(:id page) (:objects page)]) + (vals (:pages-index data))) + (keep (fn [[cid component]] + (when (seq (:objects component)) + [cid (:objects component)])) + (:components data)))) + +(defn- semantic-fixture + "One rich file exercising every indexed attribute: + + - page 1 holds a board with three children, two text shapes whose + content nodes reference a typography (one of them an undefined id), + and a rect referencing an undefined colour; + - :comp-1 (frame, child, grandchild) has a copy with labelled children; + - :comp-2 is deleted through a raw :del-component change, so its record + keeps the main-instance subtree in its own :objects; + - :comp-a/:comp-b/:comp-c model a variant swap: the copy of :comp-c + carries a nested instance of :comp-a which is swapped for :comp-b, + seeding the swapped-in head with a swap slot; + - two token sets hold four tokens; three are applied to shapes, one of + them under two attributes, and one applied name the lib never defines; + - page 2 holds one rect referencing a library colour. + + Returns {:file file :data data :db db}." + [] + ;; Asset ids that are labelled but never added to the library: references + ;; to them must produce no edge. + (thi/new-id! :color-ghost) + (thi/new-id! :typo-ghost) + + (let [file (-> (thf/sample-file :semantic-file :page-label :main-page) + (ths/add-sample-library-color :color-fill :name "Fill red" :color "#ff0000") + (ths/add-sample-library-color :color-stroke :name "Stroke blue" :color "#0000ff") + (ths/add-sample-library-color :color-unused :name "Unused green" :color "#00ff00") + (ths/add-sample-typography :typo-main :name "Main typography") + (ths/add-sample-typography :typo-unused :name "Unused typography") + (tho/add-frame :board :name "Board") + (ths/add-sample-shape :board-rect {:type :rect + :name "Board rect" + :parent-label :board + :fills [(sample-fill (thi/id :color-fill))] + :strokes [(sample-stroke (thi/id :color-stroke))]}) + (ths/add-sample-shape :board-circle {:type :circle + :name "Board circle" + :parent-label :board + :fills [(sample-fill (thi/id :color-ghost))]}) + (tho/add-text :board-text "Board label" :text-params {:parent-label :board}) + (ths/add-sample-shape :typo-text (refs-text-shape (thi/id :typo-main) (thi/id :color-fill))) + (ths/add-sample-shape :ghost-typo-text (refs-text-shape (thi/id :typo-ghost) nil)) + (ths/add-sample-shape :ghost-rect {:type :rect + :name "Ghost rect" + :fills [(sample-fill (thi/id :color-ghost))]}) + (tho/add-frame :comp-1-root :name "C1 root") + (ths/add-sample-shape :comp-1-child {:type :rect + :name "C1 child" + :parent-label :comp-1-root}) + (ths/add-sample-shape :comp-1-grandchild {:type :circle + :name "C1 grandchild" + :parent-label :comp-1-child}) + (thc/make-component :comp-1 :comp-1-root) + (thc/instantiate-component :comp-1 :comp-1-copy + :children-labels [:comp-1-copy-child :comp-1-copy-grandchild]) + (tho/add-frame :comp-2-root :name "C2 root") + (ths/add-sample-shape :comp-2-child {:type :rect + :name "C2 child" + :parent-label :comp-2-root}) + (thc/make-component :comp-2 :comp-2-root))] + + (let [file (thf/apply-changes file {:redo-changes [{:type :del-component + :id (thi/id :comp-2)}]}) + file (-> file + (tho/add-frame :comp-a-root :name "CA root") + (thc/make-component :comp-a :comp-a-root) + (tho/add-frame :comp-b-root :name "CB root") + (thc/make-component :comp-b :comp-b-root) + (tho/add-frame :comp-c-root :name "CC root") + (thc/instantiate-component :comp-a :nested-a :parent-label :comp-c-root) + (thc/make-component :comp-c :comp-c-root) + (thc/instantiate-component :comp-c :comp-c-copy :children-labels [:nested-a-copy]) + (thc/component-swap :nested-a-copy :comp-b :swapped-b)) + + file (-> file + (tht/add-tokens-lib) + (tht/update-tokens-lib + (fn [lib] + (-> lib + (ctob/add-set (ctob/make-token-set :id (thi/new-id! :token-set-a) + :name "core")) + (ctob/add-set (ctob/make-token-set :id (thi/new-id! :token-set-b) + :name "layout")) + (ctob/add-token (thi/id :token-set-a) + (ctob/make-token :id (thi/new-id! :token-color-fill) + :name "color.fill" + :type :color + :value "#112233")) + (ctob/add-token (thi/id :token-set-a) + (ctob/make-token :id (thi/new-id! :token-color-stroke) + :name "color.stroke" + :type :color + :value "#445566")) + (ctob/add-token (thi/id :token-set-b) + (ctob/make-token :id (thi/new-id! :token-size) + :name "size.dim" + :type :dimensions + :value 100)) + (ctob/add-token (thi/id :token-set-b) + (ctob/make-token :id (thi/new-id! :token-spacing) + :name "spacing.gap" + :type :spacing + :value 8)))))) + + file (-> file + ;; one token applied under two attributes: two uses + (tht/apply-token-to-shape :board-rect "size.dim" [:width :height] [:width :height] 100) + ;; one token applied by two shapes: two uses + (tht/apply-token-to-shape :board-rect "color.fill" [:fill] [:fill] "#112233") + (tht/apply-token-to-shape :board-circle "color.fill" [:fill] [:fill] "#112233") + ;; an applied name the lib never defines: no use + (tht/apply-token-to-shape :ghost-rect "ghost.token" [:fill] [:fill] "#000000")) + + file (-> file + (thf/add-sample-page :second-page :name "Second page") + (ths/add-sample-shape :page2-rect {:type :rect + :name "P2 rect" + :fills [(sample-fill (thi/id :color-fill))]}))] + + (thf/validate-file! file) + {:file file + :data (:data file) + :db (overlay/build (:data file) file)}))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; components +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest component-inventory-matches-the-component-record-map + ;; beadpot:tests/graph/transform/test_components.py::test_component_nodes_created + ;; Oracle: the `:components` map of the data, and `ctkl/get-component` + ;; include-deleted behaviour. The overlay indexes every record, deleted + ;; ones included; the Ladybug projection drops deleted components, so the + ;; two counts diverge on this fixture by design. + (let [{:keys [data db]} (semantic-fixture) + records (:components data) + deleted-id (thi/id :comp-2) + deleted (ctkl/get-component data deleted-id true)] + + (t/is (= (count records) (:components (queries/stats db)))) + (t/is (= (count (ctkl/components-seq data)) + (- (:components (queries/stats db)) + (count (ctkl/deleted-components-seq data))))) + + ;; the deleted record is an entity flagged :component/deleted + (t/is (true? (:deleted deleted))) + (t/is (true? (:component/deleted (d/entity db (d/entid db [:component/id deleted-id]))))) + + ;; the oracle: include-deleted? controls visibility; the overlay keeps it + (t/is (nil? (ctkl/get-component data deleted-id))) + (t/is (some? (ctkl/get-component data deleted-id true))) + + ;; the :del-component change snapshotted the main-instance subtree into + ;; the record's own :objects, so the overlay has a component container + ;; over that copy + (t/is (seq (:objects deleted))) + (let [container-eid (queries/container-eid db deleted-id) + snapshot-ids (d/q '[:find [?s ...] + :in $ ?id + :where + [?s :shape/container ?c] + [?c :container/id ?id]] + db deleted-id)] + (t/is (= :component (:container/kind (d/entity db container-eid)))) + (t/is (= (count (:objects deleted)) (count snapshot-ids))) + (doseq [sid (keys (:objects deleted))] + (t/is (some? (queries/shape-eid db container-eid sid)) + (str "snapshot shape " sid)))) + + ;; the inventory the rest of the suite leans on, pinned once: + ;; 22 page shapes + 2 root frames + 2 snapshot shapes = 26 shape + ;; entities; 2 pages + the deleted component's snapshot = 3 containers + (t/is (= {:documents 1 + :containers 3 + :shapes 26 + :components 5 + :colors 3 + :typographies 2 + :token-sets 2 + :tokens 4 + :token-uses 4} + (dissoc (queries/stats db) :datoms))))) + +(t/deftest components-are-children-of-the-document + ;; beadpot:tests/graph/transform/test_components.py::test_component_nodes_are_children_of_document + ;; Oracle: the document entity of the overlay. Every component record, + ;; deleted ones included, is a child of the one document entity. + (let [{:keys [data db]} (semantic-fixture) + doc-eid (d/entid db [:document/id (:id data)]) + attached (d/q '[:find ?c ?d + :where + [?c :component/document ?d]] + db)] + (t/is (= (count (:components data)) (count attached))) + (t/is (every? #(= doc-eid (second %)) attached)))) + +(t/deftest refers-to-pairs-match-shape-refs + ;; beadpot:tests/graph/transform/test_components.py::test_refers_to_edges_match_shape_refs + ;; One RefersTo per resolvable shape-ref, each pointing at the referenced + ;; shape. Oracle: `ctk/is-main-of?` on the page objects. The rule itself + ;; is unscoped; the page scoping here mirrors the Ladybug projection, + ;; which materialises page shapes only. + (let [{:keys [data db]} (semantic-fixture) + pages (vals (:pages-index data)) + pairs (d/q '[:find ?sid ?tid + :in $ % + :where + (on-page ?s) + (refers-to ?s ?t) + (on-page ?t) + [?s :shape/id ?sid] + [?t :shape/id ?tid]] + db queries/rules) + shapes (mapcat #(vals (:objects %)) pages) + refs (filter :shape-ref shapes) + on-page? (fn [id] (some #(contains? (:objects %) id) pages))] + + ;; every on-page shape with a resolvable :shape-ref has an outgoing pair + (t/is (= (set (map :id (filter #(on-page? (:shape-ref %)) refs))) + (set (map first pairs)))) + + ;; every pair is a main link in the oracle's reading, and the target id + ;; equals the source's :shape-ref + (doseq [[sid tid] pairs] + (let [objects (some (fn [p] (when (contains? (:objects p) sid) (:objects p))) + pages) + source (get objects sid) + target (get objects tid)] + (t/is (some? source)) + (t/is (ctk/is-main-of? target source)))) + + ;; all six copy shapes on the fixture resolve + (t/is (= 6 (count pairs))))) + +(t/deftest instance-heads-link-only-to-live-components + ;; beadpot:tests/graph/transform/test_components.py::test_all_instance_heads_linked_to_their_component + ;; Oracle: `ctk/instance-of?`. The is-instance-of rule scoped to page + ;; shapes must equal a scan of the predicate over the live component + ;; records. The deleted component contributes nothing, even though its + ;; orphaned main root still passes the raw predicate. + (let [{:keys [data db]} (semantic-fixture) + live-comps (ctkl/components-seq data) + rule-pairs (set (d/q '[:find ?cid ?sid + :in $ % + :where + (on-page ?s) + (is-instance-of ?s ?c) + [?c :component/id ?cid] + [?s :shape/id ?sid]] + db queries/rules)) + expected (set (for [component live-comps + [pid page] (:pages-index data) + [sid shape] (:objects page) + :when (ctk/instance-of? shape (:id data) (:id component))] + [(:id component) sid])) + deleted-id (thi/id :comp-2)] + + (t/is (= expected rule-pairs)) + (t/is (= 8 (count rule-pairs))) + + ;; no link to the deleted component + (t/is (empty? (d/q '[:find [?sid ...] + :in $ % ?cid + :where + (is-instance-of ?s ?c) + [?c :component/id ?cid] + [?s :shape/id ?sid]] + db queries/rules deleted-id))) + + ;; but its orphaned main root still passes the raw predicate + (let [main-root (get-in data [:pages-index (thi/id :main-page) + :objects (thi/id :comp-2-root)])] + (t/is (some? main-root)) + (t/is (ctk/instance-of? main-root (:id data) deleted-id))))) + +(t/deftest main-instance-frames-are-among-the-linked-heads + ;; beadpot:tests/graph/transform/test_components.py::test_main_instances_are_linked + ;; Oracle: the component records' :main-instance-page/:main-instance-id. + ;; One main instance per live component, and each of those frames is an + ;; instance head linked through `queries/instances-of`. + (let [{:keys [data db]} (semantic-fixture) + triples (queries/component-main-instances db) + live (ctkl/components-seq data)] + + (t/is (= (set (map :id (filter #(and (:main-instance-id %) + (:main-instance-page %)) + live))) + (set (map first triples)))) + (t/is (= (count live) (count triples))) + (doseq [[cid pid mid] triples] + (t/is (contains? (set (queries/instances-of db cid (:id data))) + [pid mid]))))) + +(t/deftest parent-heads-match-the-container-walk + ;; No beadpot counterpart: this is the overlay's own pin that its parent + ;; topology equals the document's. Oracle: `ctn/get-parent-heads` over the + ;; page objects, order included (top-down), for every shape on every page. + (let [{:keys [data db]} (semantic-fixture)] + (doseq [[pid page] (:pages-index data) + [sid shape] (:objects page)] + (let [expected (mapv :id (ctn/get-parent-heads (:objects page) shape)) + actual (queries/parent-heads db pid sid)] + (t/is (= expected actual) + (str "parent heads of " sid)))) + + ;; a copy's descendant: the copy root is its only head + (t/is (= [(thi/id :comp-1-copy)] + (queries/parent-heads db (thi/id :main-page) + (thi/id :comp-1-copy-grandchild)))) + + ;; a nested instance: two heads, outer first + (t/is (= [(thi/id :comp-c-root) (thi/id :nested-a)] + (queries/parent-heads db (thi/id :main-page) (thi/id :nested-a)))))) + +(t/deftest instances-of-matches-an-instance-of-scan + ;; beadpot:tests/graph/transform/test_components.py::test_all_instance_heads_linked_to_their_component + ;; (the exhaustive complement: the query against the scan) + ;; Oracle: `ctk/instance-of?` over every page's objects. The query is the + ;; raw index lookup: it does not check whether the component record is + ;; live, which is the is-instance-of rule's business, so the scan runs + ;; over every component record, deleted ones included. + (let [{:keys [data db]} (semantic-fixture)] + (doseq [component (vals (:components data))] + (let [expected (set (for [[pid page] (:pages-index data) + [sid shape] (:objects page) + :when (ctk/instance-of? shape (:id data) (:id component))] + [pid sid]))] + (t/is (= expected (set (queries/instances-of db (:id component) (:id data)))) + (str "instances of " (:name component))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; descendants and identity +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest descendants-and-shape-identity-match-the-document + ;; beadpot:tests/graph/transform/test_denormalization.py, the page_id and + ;; component_id denormalization suite, mapped onto the overlay's identity + ;; claim: shape ids are not unique, the (container, shape) pair is, so + ;; every page object, the uuid/zero root frame of every page included, + ;; must resolve through `queries/shape-eid`. The overlay does NOT + ;; denormalize component-id downward (beadpot and Ladybug do): the + ;; [?a :shape/component-id _] datom must equal `ctk/instance-head?` + ;; exactly, or the is-instance-of rule stops answering `ctk/instance-of?`. + ;; Oracle: `cfh/get-children-ids` and `ctk/instance-head?`. + (let [{:keys [data db]} (semantic-fixture) + page1-id (thi/id :main-page) + page1 (get-in data [:pages-index page1-id]) + board-id (thi/id :board) + objects (:objects page1)] + + ;; descendants: the overlay formulation of cfh/get-children-ids + (t/is (= (set (cfh/get-children-ids objects board-id)) + (queries/descendant-ids db page1-id board-id))) + (t/is (= (set (filter #(= :rect (:type (get objects %))) + (cfh/get-children-ids objects board-id))) + (queries/descendant-ids-of-type db page1-id board-id :rect))) + (t/is (= (set (filter #(= :text (:type (get objects %))) + (cfh/get-children-ids objects board-id))) + (queries/descendant-ids-of-type db page1-id board-id :text))) + (t/is (= #{} (queries/descendant-ids db page1-id (thi/id :board-rect)))) + + ;; identity: every object of every page resolves, uuid/zero included + (doseq [[pid page] (:pages-index data) + [sid _shape] (:objects page)] + (let [container-eid (queries/container-eid db pid) + shape-eid (queries/shape-eid db container-eid sid)] + (t/is (some? shape-eid) + (str "shape " sid " of page " pid)))) + + ;; uuid/zero keys the root frame of every page: two distinct entities + (let [p1-root (queries/shape-eid db (queries/container-eid db page1-id) + uuid/zero) + p2-root (queries/shape-eid db (queries/container-eid db (thi/id :second-page)) + uuid/zero)] + (t/is (some? p1-root)) + (t/is (some? p2-root)) + (t/is (not= p1-root p2-root)) + (t/is (= 2 (count (queries/shape-eids db uuid/zero))))) + + ;; no downward denormalization: the overlay stores component-id iff the + ;; helper sees a head + (doseq [[pid page] (:pages-index data) + [sid shape] (:objects page)] + (let [entity (d/entity db (queries/shape-eid db (queries/container-eid db pid) + sid))] + (t/is (= (boolean (ctk/instance-head? shape)) + (boolean (some? (:shape/component-id entity)))) + (str "component-id denormalization on " sid)) + (when (:component-id shape) + (t/is (= (:component-id shape) (:shape/component-id entity)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; swap slots +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest fills-swap-slot-matches-swap-slot-entries + ;; beadpot:tests/graph/transform/test_variants.py::test_fills_swap_slot_count_matches_fixture + ;; and ::test_fills_swap_slot_id_matches_touched_entry + ;; Oracle: `ctk/get-swap-slot` over the document. The swapped-in nested + ;; copy root carries the replaced shape's id as its swap slot; the overlay + ;; surfaces exactly one FillsSwapSlot per document swap-slot entry whose + ;; target resolves. beadpot's test_swap_slot_entries_stripped_from_touched + ;; is vacuous here: the overlay never stores :touched, so there is nothing + ;; to strip. + (let [{:keys [data db]} (semantic-fixture) + pairs (d/q '[:find ?sid ?sslot ?tid + :in $ % + :where + (on-page ?s) + (fills-swap-slot ?s ?t) + (on-page ?t) + [?s :shape/id ?sid] + [?s :shape/swap-slot ?sslot] + [?t :shape/id ?tid]] + db queries/rules) + slots (for [[_cid objects] (document-containers data) + shape (vals objects) + :let [slot (ctk/get-swap-slot shape)] + :when (some? slot)] + [(:id shape) slot])] + + ;; the count matches the swap-slot entries the helper finds + (t/is (= (count slots) (count pairs))) + + ;; one swapped-in head, one slot, one edge + (t/is (= 1 (count pairs))) + + (doseq [[sid sslot tid] pairs] + ;; the slot names the replaced shape: source and target differ, and + ;; the target is a shape on a page + (t/is (= sslot tid)) + (t/is (not= sid tid)) + (t/is (= (thi/id :swapped-b) sid)) + (t/is (= (thi/id :nested-a) tid))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; tokens +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest token-inventory-matches-the-tokens-lib + ;; beadpot:tests/graph/transform/test_tokens.py::test_graph_round_trip_preserves_token_inventory + ;; and ::test_graph_all_tokens_present + ;; Oracle: the tokens lib itself. The overlay stores identity, type and + ;; set membership; values and themes stay in the lib. + (let [{:keys [data db]} (semantic-fixture) + lib (:tokens-lib data) + tokens (ctob/get-all-tokens lib) + graph-names (set (d/q '[:find [?n ...] + :where + [?t :token/name ?n]] + db)) + graph-types (into {} (d/q '[:find ?type (count ?t) + :where + [?t :token/type ?type]] + db))] + + (t/is (= (set (map :name tokens)) graph-names)) + (t/is (= (frequencies (map :type tokens)) graph-types)) + (t/is (= (count (ctob/get-sets lib)) (:token-sets (queries/stats db)))) + (t/is (= 4 (:tokens (queries/stats db)))) + + ;; token -> set membership, per the lib's own getters + (doseq [set* (ctob/get-sets lib) + token (vals (ctob/get-tokens- set*))] + (let [set-eid (d/entid db [:token-set/id (ctob/get-id set*)]) + tok-eid (d/entid db [:token/id (:id token)])] + (t/is (some? tok-eid)) + (t/is (= set-eid (:db/id (:token/set (d/entity db tok-eid)))) + (str "set of token " (:name token))) + (t/is (= (ctob/get-name set*) + (:token-set/name (d/entity db set-eid)))))))) + +(t/deftest applied-tokens-produce-exactly-the-resolvable-uses + ;; beadpot:tests/graph/transform/test_tokens.py::test_link_applied_tokens_creates_exact_edge_set + ;; plus ::test_shared_token_has_multiple_incoming_edges and + ;; ::test_same_token_two_attributes_yields_two_edges + ;; Oracle: a scan of every container's :applied-tokens, restricted to + ;; names the lib defines; the overlay's token-use entities must equal it. + ;; beadpot's enum-key parsing test is a document-format concern that + ;; Clojure keywords make moot. + (let [{:keys [data db]} (semantic-fixture) + lib-names (into #{} (map :name) (ctob/get-all-tokens (:tokens-lib data))) + expected (set (for [[cid objects] (document-containers data) + shape (vals objects) + [prop name] (:applied-tokens shape) + :when (contains? lib-names name)] + [cid (:id shape) prop])) + actual (set (mapcat #(queries/shapes-using-token db %) lib-names))] + + (t/is (= expected actual)) + (t/is (= 4 (:token-uses (queries/stats db)))) + + ;; a token applied by two shapes has two uses + (let [shared (queries/shapes-using-token db "color.fill")] + (t/is (= #{(thi/id :board-rect) (thi/id :board-circle)} + (set (map second shared))))) + + ;; one shape applying one token under two attributes yields two triples + (let [two-attrs (queries/shapes-using-token db "size.dim")] + (t/is (= 2 (count two-attrs))) + (t/is (= 1 (count (set (map second two-attrs))))) + (t/is (= #{:width :height} (set (map #(nth % 2) two-attrs))))) + + ;; a name the lib never defines produces no edge + (t/is (empty? (queries/shapes-using-token db "ghost.token"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; colors and typographies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest used-colors-and-typographies-match-the-raw-refs + ;; beadpot's LinkUsedColors and LinkUsedTypographies transforms, verified + ;; against the raw shape maps. Oracle: the shapes whose fills, strokes, or + ;; text-content fills carry the color's ref id, and the shapes whose text + ;; content carries the typography's ref id, read straight off the maps. + ;; Unresolvable refs (id not in the library) produce no edge, mirroring + ;; beadpot's node_exists guard. + (let [{:keys [data db]} (semantic-fixture) + containers (document-containers data) + fill-refs (fn [fills] (into #{} (keep :fill-color-ref-id) fills)) + stroke-refs (fn [strokes] (into #{} (keep :stroke-color-ref-id) strokes)) + node-fill-refs (fn [content] + (into #{} (comp (mapcat :fills) (keep :fill-color-ref-id)) + (txt/node-seq content))) + node-typo-refs (fn [content] + (into #{} (keep :typography-ref-id) (txt/node-seq content))) + color-users (fn [color-id] + (set (for [[cid objects] containers + shape (vals objects) + :when (or (contains? (fill-refs (:fills shape)) color-id) + (contains? (stroke-refs (:strokes shape)) color-id) + (contains? (node-fill-refs (:content shape)) color-id))] + [cid (:id shape)]))) + typo-users (fn [typo-id] + (set (for [[cid objects] containers + shape (vals objects) + :when (contains? (node-typo-refs (:content shape)) typo-id)] + [cid (:id shape)])))] + + (doseq [color-id (keys (:colors data))] + (t/is (= (color-users color-id) + (set (queries/shapes-using-color db color-id))) + (str "users of color " color-id))) + + (doseq [typo-id (keys (:typographies data))] + (t/is (= (typo-users typo-id) + (set (queries/shapes-using-typography db typo-id))) + (str "users of typography " typo-id))) + + ;; pinned membership: fill, text-content fill, and cross-page use + (t/is (= #{[(thi/id :main-page) (thi/id :board-rect)] + [(thi/id :main-page) (thi/id :typo-text)] + [(thi/id :second-page) (thi/id :page2-rect)]} + (set (queries/shapes-using-color db (thi/id :color-fill))))) + (t/is (= #{[(thi/id :main-page) (thi/id :board-rect)]} + (set (queries/shapes-using-color db (thi/id :color-stroke))))) + (t/is (= #{[(thi/id :main-page) (thi/id :typo-text)]} + (set (queries/shapes-using-typography db (thi/id :typo-main))))) + (t/is (empty? (queries/shapes-using-typography db (thi/id :typo-unused)))) + + ;; unresolvable refs produce no edge + (t/is (empty? (queries/shapes-using-color db (thi/id :color-ghost)))) + (t/is (empty? (queries/shapes-using-typography db (thi/id :typo-ghost)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; parity counting +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(t/deftest ladybug-parity-counts-pin-the-fixture + ;; Hand-computed expectations under the Ladybug projection's conventions, + ;; so the parity fn itself is pinned: page shapes minus root frames, + ;; pages, and live components. 22 page shapes + 2 pages + 4 live + ;; components = 28 IsChildOf; 8 on-page instance heads against live + ;; components; 6 on-page resolvable shape-refs; 1 on-page swap slot. + (let [{:keys [data db]} (semantic-fixture) + pages (vals (:pages-index data)) + page-shapes (remove #(= uuid/zero (:id %)) + (mapcat #(vals (:objects %)) pages)) + live-comps (ctkl/components-seq data) + on-page? (fn [id] (some #(contains? (:objects %) id) pages)) + live-head? (fn [shape] + (some (fn [component] + (ctk/instance-of? shape (:id data) (:id component))) + live-comps)) + derived {:is-child-of (+ (count page-shapes) + (count pages) + (count live-comps)) + :is-instance-of (count (filter live-head? page-shapes)) + :refers-to (count (filter #(and (:shape-ref %) + (on-page? (:shape-ref %))) + page-shapes)) + :fills-swap-slot (count (filter #(let [slot (ctk/get-swap-slot %)] + (and slot (on-page? slot))) + page-shapes))}] + + (t/is (= derived (queries/ladybug-parity-counts db))) + (t/is (= {:is-child-of 28 + :is-instance-of 8 + :refers-to 6 + :fills-swap-slot 1} + (queries/ladybug-parity-counts db)))))