mirror of
https://github.com/penpot/penpot.git
synced 2026-11-04 17:10:39 +00:00
5d1c7992c2
Apply Japanese attributes to text selections and whole shapes without splitting ruby or warichu spans. Respect vertical writing when resizing text and placing selection handles and pointer cursors. Anchor native IME input to the WASM caret, keep composition previews out of the store until commit, and add an optional geometry overlay. Cover editor styles, serialization, fallback fonts and cursor behavior.
742 lines
25 KiB
Clojure
742 lines
25 KiB
Clojure
;; This Source Code Form is subject to the terms of the Mozilla Public
|
|
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
|
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
|
;;
|
|
;; Copyright (c) KALEIDOS SUBSIDIARY SL
|
|
|
|
(ns debug
|
|
(:require
|
|
[app.common.data :as d]
|
|
[app.common.data.macros :as dm]
|
|
[app.common.exceptions :as ex]
|
|
[app.common.files.helpers :as cfh]
|
|
[app.common.files.repair :as cfr]
|
|
[app.common.files.validate :as cfv]
|
|
[app.common.json :as json]
|
|
[app.common.logging :as l]
|
|
[app.common.pprint :as pp]
|
|
[app.common.render-wasm.helpers :as wasm.h]
|
|
[app.common.render-wasm.mem :as wasm.mem]
|
|
[app.common.render-wasm.wasm :as wasm]
|
|
[app.common.transit :as t]
|
|
[app.common.types.component :as ctk]
|
|
[app.common.types.components-list :as ctkl]
|
|
[app.common.types.container :as ctn]
|
|
[app.common.types.file :as ctf]
|
|
[app.common.uuid :as uuid]
|
|
[app.main.data.changes :as dwc]
|
|
[app.main.data.common :as dcm]
|
|
[app.main.data.dashboard.shortcuts]
|
|
[app.main.data.helpers :as dsh]
|
|
[app.main.data.preview :as dp]
|
|
[app.main.data.viewer.shortcuts]
|
|
[app.main.data.workspace :as dw]
|
|
[app.main.data.workspace.common :as dwcm]
|
|
[app.main.data.workspace.path.shortcuts]
|
|
[app.main.data.workspace.selection :as dws]
|
|
[app.main.data.workspace.shortcuts]
|
|
[app.main.data.workspace.undo :as dwu]
|
|
[app.main.errors :as errors]
|
|
[app.main.repo :as rp]
|
|
[app.main.store :as st]
|
|
[app.util.debug :as dbg]
|
|
[app.util.dom :as dom]
|
|
[app.util.http :as http]
|
|
[beicon.v2.core :as rx]
|
|
[cljs.pprint :refer [pprint]]
|
|
[cuerdas.core :as str]
|
|
[potok.v2.core :as ptk]
|
|
[promesa.core :as p]))
|
|
|
|
(l/set-level! :debug)
|
|
|
|
(defn- coerce-keyword
|
|
"Coerce `v` to a keyword when it is a string or keyword, nil otherwise."
|
|
[v]
|
|
(when (or (keyword? v) (string? v))
|
|
(keyword v)))
|
|
|
|
(defn ^:export set-logging
|
|
([level]
|
|
(let [level (coerce-keyword level)]
|
|
(if (l/valid-level? level)
|
|
(l/set-level! "app" level)
|
|
(js/console.warn "ignoring invalid log level:" (pr-str level)))))
|
|
([ns level]
|
|
(let [ns (coerce-keyword ns)
|
|
level (coerce-keyword level)]
|
|
(if (and (l/valid-logger? (some-> ns name))
|
|
(l/valid-level? level))
|
|
(l/set-level! (name ns) level)
|
|
(js/console.warn "ignoring invalid logging config:" (pr-str ns) (pr-str level))))))
|
|
|
|
;; These events are excluded when we activate the :events flag
|
|
(def debug-exclude-events
|
|
#{:app.main.data.workspace.notifications/handle-pointer-update
|
|
:app.main.data.workspace.notifications/handle-pointer-send
|
|
:app.main.data.websocket/send-message
|
|
:app.main.data.workspace.selection/change-hover-state})
|
|
|
|
(defn enable!
|
|
[option]
|
|
(dbg/enable! option)
|
|
(case option
|
|
:events
|
|
(set! st/*debug-events* true)
|
|
|
|
:events-times
|
|
(set! st/*debug-events-time* true)
|
|
|
|
nil)
|
|
(when-not (= option :ime)
|
|
(js* "app.main.reinit()")))
|
|
|
|
(defn disable!
|
|
[option]
|
|
(dbg/disable! option)
|
|
(case option
|
|
:events
|
|
(set! st/*debug-events* false)
|
|
|
|
:events-times
|
|
(set! st/*debug-events-time* false)
|
|
|
|
nil)
|
|
(when-not (= option :ime)
|
|
(js* "app.main.reinit()")))
|
|
|
|
(defn ^:export toggle-debug
|
|
[name]
|
|
(let [option (keyword name)]
|
|
(if (dbg/enabled? option)
|
|
(disable! option)
|
|
(enable! option))))
|
|
|
|
(defn ^:export debug-all
|
|
[]
|
|
(reset! dbg/state dbg/options)
|
|
(js* "app.main.reinit()"))
|
|
|
|
(defn ^:export debug-none
|
|
[]
|
|
(reset! dbg/state #{})
|
|
(js* "app.main.reinit()"))
|
|
|
|
(defn ^:export tap
|
|
"Transducer function that can execute a side-effect `effect-fn` per input"
|
|
[effect-fn]
|
|
(fn [rf]
|
|
(fn
|
|
([] (rf))
|
|
([result] (rf result))
|
|
([result input]
|
|
(effect-fn input)
|
|
(rf result input)))))
|
|
|
|
(defn ^:export logjs
|
|
([str] (tap (partial logjs str)))
|
|
([str val]
|
|
(js/console.log str (json/->js val))
|
|
val))
|
|
|
|
(defn- wasm-read-len-prefixed-utf8
|
|
"Reads a `[u32 byte_len][utf8 bytes...]` buffer returned by WASM and frees it.
|
|
Returns a JS string (possibly empty)."
|
|
[ptr]
|
|
(when (and ptr (not (zero? ptr)))
|
|
(let [heap-u8 (wasm.mem/get-heap-u8)
|
|
heap-u32 (wasm.mem/get-heap-u32)
|
|
len (aget heap-u32 (wasm.mem/->offset-32 ptr))
|
|
start (+ ptr 4)
|
|
end (+ start len)
|
|
decoder (js/TextDecoder. "utf-8")
|
|
text (.decode decoder (.subarray heap-u8 start end))]
|
|
(wasm.mem/free)
|
|
text)))
|
|
|
|
(defn ^:export wasmCaptureFrames
|
|
[amount]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_capture_frames"))]
|
|
(if (fn? f)
|
|
(wasm.h/call module "_capture_frames" amount)
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _render_stats"))))
|
|
|
|
(defn ^:export wasmRenderStats
|
|
[]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_render_stats"))]
|
|
(if (fn? f)
|
|
(wasm.h/call module "_render_stats")
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _render_stats"))))
|
|
|
|
(defn ^:export wasmAtlasConsole
|
|
"Logs the current render-wasm atlas as an image in the JS console (if present)."
|
|
[]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_debug_atlas_console"))]
|
|
(if (fn? f)
|
|
(wasm.h/call module "_debug_atlas_console")
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _debug_atlas_console"))))
|
|
|
|
(defn ^:export wasmAtlasBase64
|
|
"Returns the atlas PNG base64 (empty string if missing/empty)."
|
|
[]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_debug_atlas_base64"))]
|
|
(if (fn? f)
|
|
(let [ptr (wasm.h/call module "_debug_atlas_base64")
|
|
s (or (wasm-read-len-prefixed-utf8 ptr) "")]
|
|
s)
|
|
(do
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _debug_atlas_base64")
|
|
""))))
|
|
|
|
(defn ^:export wasmSurfaceConsole
|
|
"Logs the render-wasm surface id as an image in the JS console."
|
|
[id]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_debug_surface_console"))]
|
|
(if (fn? f)
|
|
(wasm.h/call module "_debug_surface_console" id)
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _debug_surface_console"))))
|
|
|
|
(defn ^:export wasmCacheConsole
|
|
"Logs the current render-wasm cache surface as an image in the JS console."
|
|
[]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_debug_cache_console"))]
|
|
(if (fn? f)
|
|
(wasm.h/call module "_debug_cache_console")
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _debug_cache_console"))))
|
|
|
|
(defn ^:export wasmCacheBase64
|
|
"Returns the cache surface PNG base64 (empty string if missing/empty)."
|
|
[]
|
|
(let [module wasm/internal-module
|
|
f (when module (unchecked-get module "_debug_cache_base64"))]
|
|
(if (fn? f)
|
|
(let [ptr (wasm.h/call module "_debug_cache_base64")
|
|
s (or (wasm-read-len-prefixed-utf8 ptr) "")]
|
|
s)
|
|
(do
|
|
(js/console.warn "[debug] render-wasm module not ready or missing _debug_cache_base64")
|
|
""))))
|
|
|
|
(when (exists? js/window)
|
|
(set! (.-dbg ^js js/window) json/->js)
|
|
(set! (.-pp ^js js/window) pprint))
|
|
|
|
(defonce widget-style "
|
|
background: black;
|
|
bottom: 10px;
|
|
color: white;
|
|
height: 20px;
|
|
padding-left: 8px;
|
|
position: absolute;
|
|
right: 10px;
|
|
width: 40px;
|
|
z-index: 99999;
|
|
opacity: 0.5;
|
|
")
|
|
|
|
(defn ^:export dump-state []
|
|
(logjs "state" @st/state)
|
|
nil)
|
|
|
|
(defn ^:export dump-data []
|
|
(let [fdata (-> (dsh/lookup-file @st/state)
|
|
(get :data))]
|
|
(logjs "file-data" fdata)
|
|
nil))
|
|
|
|
(defn ^:export dump-buffer []
|
|
(logjs "last-events" @st/last-events)
|
|
nil)
|
|
|
|
(defn ^:export get-state [str-path]
|
|
(let [path (->> (str/split str-path " ")
|
|
(map d/read-string)
|
|
vec)]
|
|
(js/console.log (clj->js (get-in @st/state path))))
|
|
nil)
|
|
|
|
(defn dump-objects'
|
|
[state]
|
|
(let [objects (dsh/lookup-page-objects state)]
|
|
(logjs "objects" objects)
|
|
nil))
|
|
|
|
(defn ^:export dump-objects
|
|
[]
|
|
(dump-objects' @st/state))
|
|
|
|
(defn get-object
|
|
[state name]
|
|
(let [objects (dsh/lookup-page-objects state)
|
|
result (or (d/seek (fn [shape] (= name (:name shape))) (vals objects))
|
|
(get objects (uuid/parse name)))]
|
|
result))
|
|
|
|
(defn ^:export dump-object
|
|
[name]
|
|
(clj->js (get-object @st/state name)))
|
|
|
|
(defn get-selected
|
|
[state]
|
|
(dsh/lookup-selected state))
|
|
|
|
(defn ^:export dump-selected
|
|
[]
|
|
(let [objects (dsh/lookup-page-objects @st/state)
|
|
result (->> (get-selected @st/state) (map #(get objects %)))]
|
|
(logjs "selected" result)
|
|
nil))
|
|
|
|
|
|
(defn ^:export dump-selected-edn
|
|
[]
|
|
(let [objects (dsh/lookup-page-objects @st/state)
|
|
result (->> (get-selected @st/state) (map #(get objects %)))]
|
|
(pp/pprint result {:length 30 :level 30})
|
|
nil))
|
|
|
|
(defn ^:export preview-selected
|
|
[]
|
|
(st/emit! (dp/open-preview-selected)))
|
|
|
|
(defn ^:export parent
|
|
[]
|
|
(let [objects (dsh/lookup-page-objects @st/state)
|
|
selected-id (first (dsh/get-selected-ids @st/state))
|
|
parent-id (dm/get-in objects [selected-id :parent-id])]
|
|
(when-let [parent (get objects parent-id)]
|
|
(js/console.log (str (:name parent) " - " (:id parent))))
|
|
nil))
|
|
|
|
(defn ^:export frame
|
|
[]
|
|
(let [objects (dsh/lookup-page-objects @st/state)
|
|
selected-id (first (dsh/get-selected-ids @st/state))
|
|
frame-id (dm/get-in objects [selected-id :frame-id])]
|
|
(when-let [frame (get objects frame-id)]
|
|
(js/console.log (str (:name frame) " - " (:id frame))))
|
|
nil))
|
|
|
|
(defn ^:export select-by-object-id
|
|
[object-id]
|
|
(let [[_ page-id shape-id _] (str/split object-id #"/")]
|
|
(st/emit! (dcm/go-to-workspace :page-id (uuid/parse page-id)))
|
|
(st/emit! (dws/select-shape (uuid/parse shape-id)))))
|
|
|
|
(defn ^:export select-by-id
|
|
[shape-id]
|
|
(st/emit! (dws/select-shape (uuid/parse shape-id))))
|
|
|
|
(defn dump-tree'
|
|
([state] (dump-tree' state false false false))
|
|
([state show-ids] (dump-tree' state show-ids false false))
|
|
([state show-ids show-touched] (dump-tree' state show-ids show-touched false))
|
|
([state show-ids show-touched show-modified]
|
|
(let [page-id (get state :current-page-id)
|
|
file (dsh/lookup-file state)
|
|
libraries (get state :files)]
|
|
(ctf/dump-tree file page-id libraries {:show-ids show-ids
|
|
:show-touched show-touched
|
|
:show-modified show-modified}))))
|
|
(defn ^:export dump-tree
|
|
([] (dump-tree' @st/state))
|
|
([show-ids] (dump-tree' @st/state show-ids false false))
|
|
([show-ids show-touched] (dump-tree' @st/state show-ids show-touched false))
|
|
([show-ids show-touched show-modified] (dump-tree' @st/state show-ids show-touched show-modified)))
|
|
|
|
(defn ^:export dump-subtree'
|
|
([state shape-id] (dump-subtree' state shape-id false false false))
|
|
([state shape-id show-ids] (dump-subtree' state shape-id show-ids false false))
|
|
([state shape-id show-ids show-touched] (dump-subtree' state shape-id show-ids show-touched false))
|
|
([state shape-id show-ids show-touched show-modified]
|
|
(let [page-id (get state :current-page-id)
|
|
file (dsh/lookup-file state)
|
|
libraries (get state :files)
|
|
shape-id (if (some? shape-id)
|
|
(uuid/parse shape-id)
|
|
(first (dsh/lookup-selected state)))]
|
|
(if (some? shape-id)
|
|
(ctf/dump-subtree file page-id shape-id libraries {:show-ids show-ids
|
|
:show-touched show-touched
|
|
:show-modified show-modified})
|
|
(println "no selected shape")))))
|
|
|
|
(defn ^:export dump-subtree
|
|
([shape-id] (dump-subtree' @st/state shape-id))
|
|
([shape-id show-ids] (dump-subtree' @st/state shape-id show-ids false false))
|
|
([shape-id show-ids show-touched] (dump-subtree' @st/state shape-id show-ids show-touched false))
|
|
([shape-id show-ids show-touched show-modified] (dump-subtree' @st/state shape-id show-ids show-touched show-modified)))
|
|
|
|
(defn ^:export apply-changes
|
|
"Takes a Transit JSON changes"
|
|
[^string changes*]
|
|
|
|
(let [file-id (:current-file-id @st/state)
|
|
changes (t/decode-str changes*)]
|
|
(st/emit! (dwc/commit-changes {:redo-changes changes
|
|
:undo-changes []
|
|
:save-undo? true
|
|
:file-id file-id}))))
|
|
|
|
(defn ^:export fetch-apply
|
|
[^string url]
|
|
(-> (p/let [response (js/fetch url)]
|
|
(.text response))
|
|
(p/then apply-changes)))
|
|
|
|
(def ^:private simulated-error-body
|
|
"Stands in for the error page a proxy or CDN writes when it answers instead
|
|
of the backend."
|
|
"<html><head><title>Simulated error</title></head><body>simulated intermediary response</body></html>")
|
|
|
|
(defonce ^:private pending-http-error (atom nil))
|
|
|
|
(defn- simulated-status
|
|
"Status to answer `uri` with, or nil to let the request through. A
|
|
simulation without a deadline answers one call; one with a deadline answers
|
|
every matching call until it runs out."
|
|
[uri]
|
|
(let [{:keys [method status until]} @pending-http-error]
|
|
(when (and (some? method)
|
|
(str/includes? uri (str "/api/main/methods/" method)))
|
|
(cond
|
|
(nil? until) (do (reset! pending-http-error nil) status)
|
|
(< (js/Date.now) until) status
|
|
:else (do (reset! pending-http-error nil) nil)))))
|
|
|
|
;; The original fetch and the wrapper standing in for it, or nil when unhooked.
|
|
(defonce ^:private http-error-hook (atom nil))
|
|
|
|
(defn- install-http-error-hook!
|
|
[]
|
|
(when (nil? @http-error-hook)
|
|
(let [original (unchecked-get js/globalThis "fetch")
|
|
wrapper (fn [input params]
|
|
(let [uri (if (string? input) input (unchecked-get input "url"))]
|
|
(if-let [status (simulated-status uri)]
|
|
(p/resolved (js/Response. simulated-error-body
|
|
#js {:status status
|
|
:headers #js {"content-type" "text/html"}}))
|
|
(.call original js/globalThis input params))))]
|
|
(reset! http-error-hook {:original original :wrapper wrapper})
|
|
(unchecked-set js/globalThis "fetch" wrapper))))
|
|
|
|
(defn- remove-http-error-hook!
|
|
[]
|
|
(when-let [{:keys [original wrapper]} @http-error-hook]
|
|
;; Restore only while the wrapper is still installed, so a later
|
|
;; wrapper survives.
|
|
(when (identical? wrapper (unchecked-get js/globalThis "fetch"))
|
|
(unchecked-set js/globalThis "fetch" original))
|
|
(reset! http-error-hook nil)))
|
|
|
|
(defn ^:export simulateHttpError
|
|
"Answers calls to an API method with `status` and a body that carries no
|
|
Penpot error code, the way a CDN or a corporate proxy does. Every other
|
|
request goes through untouched.
|
|
|
|
Without `seconds` the simulation is spent once it answers one call. With
|
|
`seconds` it answers every matching call for that long, which is how to
|
|
watch a save retry, warn, keep retrying and finally recover.
|
|
|
|
debug.simulateHttpError('update-file')
|
|
debug.simulateHttpError('get-comment-threads', 403)
|
|
debug.simulateHttpError('update-file', 524, 120)"
|
|
([method]
|
|
(simulateHttpError method 524 nil))
|
|
([method status]
|
|
(simulateHttpError method status nil))
|
|
([method status seconds]
|
|
(install-http-error-hook!)
|
|
(let [until (when (and (number? seconds) (pos? seconds))
|
|
(+ (js/Date.now) (* 1000 seconds)))]
|
|
(reset! pending-http-error {:method method
|
|
:status status
|
|
:until until})
|
|
(if (some? until)
|
|
(str "every " method " call will be answered with " status
|
|
" for the next " seconds " seconds")
|
|
(str "the next " method " call will be answered with " status)))))
|
|
|
|
(defn ^:export clearHttpErrorSimulation
|
|
"Stops a running simulation and takes the wrapper off `fetch`."
|
|
[]
|
|
(reset! pending-http-error nil)
|
|
(remove-http-error-hook!)
|
|
"requests reach the backend again")
|
|
|
|
(defn ^:export reset-viewport
|
|
[]
|
|
(st/emit!
|
|
dw/reset-zoom
|
|
(dw/update-viewport-position {:x (constantly 0) :y (constantly 0)})))
|
|
|
|
(defn ^:export hide-ui
|
|
[]
|
|
(st/emit!
|
|
(dw/toggle-layout-flag :hide-ui)))
|
|
|
|
|
|
(defn ^:export shortcuts
|
|
[]
|
|
|
|
(letfn [(print-shortcuts [shortcuts]
|
|
(.table js/console
|
|
(->> shortcuts
|
|
(map (fn [[key {:keys [command]}]]
|
|
[(d/name key)
|
|
(if (vector? command)
|
|
(str/join " | " command)
|
|
command)]))
|
|
(into {})
|
|
(clj->js))))]
|
|
(let [style "font-weight: bold; font-size: 1.25rem;"]
|
|
(.log js/console "%c Dashboard" style)
|
|
(print-shortcuts app.main.data.dashboard.shortcuts/shortcuts)
|
|
|
|
(.log js/console "%c Workspace" style)
|
|
(print-shortcuts app.main.data.workspace.shortcuts/shortcuts)
|
|
|
|
(.log js/console "%c Path" style)
|
|
(print-shortcuts app.main.data.workspace.path.shortcuts/shortcuts)
|
|
|
|
(.log js/console "%c Viewer" style)
|
|
(print-shortcuts app.main.data.viewer.shortcuts/shortcuts)))
|
|
nil)
|
|
|
|
(defn ^:export nodeStats
|
|
[]
|
|
(let [root-node (dom/query ".viewport .render-shapes")
|
|
num-nodes (->> (dom/seq-nodes root-node) count)]
|
|
#js {:number num-nodes}))
|
|
|
|
(defn modif->js
|
|
[modif-tree objects]
|
|
(clj->js (into {}
|
|
(map (fn [[k v]]
|
|
[(get-in objects [k :name]) v]))
|
|
modif-tree)))
|
|
|
|
(defn ^:export dump-modifiers
|
|
[]
|
|
(let [objects (dsh/lookup-page-objects @st/state)
|
|
modifiers (:workspace-modifiers @st/state)]
|
|
(js/console.log (modif->js modifiers objects))
|
|
nil))
|
|
|
|
(defn ^:export set-workspace-read-only
|
|
[read-only?]
|
|
(st/emit! (dwcm/set-workspace-read-only read-only?)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; REPAIR & VALIDATION
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Validation and repair
|
|
|
|
(defn ^:export validate
|
|
([] (validate nil))
|
|
([shape-id]
|
|
(let [file (dsh/lookup-file @st/state)
|
|
libraries (get @st/state :files)]
|
|
(try
|
|
(->> (if-let [shape-id (some-> shape-id uuid/parse)]
|
|
(let [page (dm/get-in file [:data :pages-index (get @st/state :current-page-id)])]
|
|
(cfv/validate-shape shape-id file page libraries))
|
|
(cfv/validate-file file libraries))
|
|
(group-by :code)
|
|
(clj->js))
|
|
(catch :default cause
|
|
(ex/print-throwable cause))))))
|
|
|
|
(defn ^:export validate-schema
|
|
[]
|
|
(try
|
|
(let [file (dsh/lookup-file @st/state)]
|
|
(cfv/validate-file-schema! file))
|
|
(catch :default cause
|
|
(ex/print-throwable cause))))
|
|
|
|
(defn ^:export repair
|
|
[reload?]
|
|
(st/emit!
|
|
(ptk/reify ::repair-current-file
|
|
ptk/EffectEvent
|
|
(effect [_ state _]
|
|
(let [features (:features state)
|
|
sid (:session-id state)
|
|
|
|
file (dsh/lookup-file state)
|
|
libs (get state :files)
|
|
|
|
errors (cfv/validate-file file libs)
|
|
_ (l/dbg :hint "repair current file" :errors (count errors))
|
|
|
|
changes (cfr/repair-file file libs errors)
|
|
|
|
params {:id (:id file)
|
|
:revn (:revn file)
|
|
:vern (:vern file)
|
|
:session-id sid
|
|
:changes changes
|
|
:features features
|
|
:skip-validate true}]
|
|
|
|
(->> (rp/cmd! :update-file params)
|
|
(rx/subs! (fn [_]
|
|
(when reload?
|
|
(dom/reload-current-window)))
|
|
(fn [cause]
|
|
(ex/print-throwable cause)))))))))
|
|
|
|
(defn ^:export fix-orphan-shapes
|
|
[]
|
|
(st/emit! (dw/fix-orphan-shapes)))
|
|
|
|
(defn ^:export find-components-norefs
|
|
[]
|
|
(st/emit! (dw/find-components-norefs)))
|
|
|
|
(defn- set-shape-ref*
|
|
[id shape-ref]
|
|
(ptk/reify ::set-shape-ref
|
|
ptk/WatchEvent
|
|
(watch [_ _ _]
|
|
(let [shape-id (uuid/parse id)
|
|
shape-ref (uuid/parse shape-ref)]
|
|
(rx/of (dw/update-shape shape-id {:shape-ref shape-ref}))))))
|
|
|
|
(defn ^:export set-shape-ref
|
|
[id shape-ref]
|
|
(st/emit! (set-shape-ref* id shape-ref)))
|
|
|
|
(defn ^:export network-averages
|
|
[]
|
|
(.log js/console (clj->js @http/network-averages)))
|
|
|
|
|
|
(defn print-last-exception
|
|
[]
|
|
(some-> errors/last-exception ex/print-throwable))
|
|
|
|
|
|
(defn ^:export dbg
|
|
[o]
|
|
(app.common.pprint/pprint o {:level 100 :length 100}))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; PRUNE UNRELATED ITEMS
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defn- get-related-ids
|
|
"Given a `context` map (:pindex, :fdata) and a `[page-id id]` pair, returns
|
|
the set of `[page-id id]` pairs directly related to it, NOT recursively:
|
|
- its children (including itself)
|
|
- its ancestors
|
|
- the main instance `[page-id id]` of its component, if it's inside a
|
|
component copy of a component defined in the current file (libraries
|
|
are ignored)
|
|
|
|
Ids are only unique within a page, so every id is always tracked together
|
|
with the page it belongs to."
|
|
[{:keys [pindex fdata]} [page-id id]]
|
|
(let [page-objects (-> (get pindex page-id) :objects)
|
|
shape (get page-objects id)]
|
|
(if (nil? shape)
|
|
#{}
|
|
(let [related (-> #{}
|
|
(into (map (partial vector page-id) (cfh/get-parent-ids page-objects id)))
|
|
(into (map (partial vector page-id) (cfh/get-children-ids-with-self page-objects id))))
|
|
head (when (ctk/in-component-copy? shape)
|
|
(ctn/get-head-shape page-objects shape))
|
|
component (when (and (some? head) (= (:component-file head) (:id fdata)))
|
|
(ctkl/get-component fdata (:component-id head)))]
|
|
(cond-> related
|
|
(some? component)
|
|
(conj [(:main-instance-page component) (:main-instance-id component)]))))))
|
|
|
|
(defn ^:export prune-unrelated-items
|
|
"This function is DESTRUCTIVE. It deletes from the current file all the pages and layers unrelated to the selection.
|
|
It is used to isolate bugs"
|
|
[]
|
|
(let [state @st/state
|
|
current-pid (:current-page-id state)
|
|
selected (get-selected state)
|
|
|
|
fdata (dsh/lookup-file-data state)
|
|
pindex (:pages-index fdata)
|
|
|
|
context {:pindex pindex
|
|
:fdata fdata}
|
|
|
|
related
|
|
(loop [related (into #{} (map (partial vector current-pid)) selected)]
|
|
(let [expanded (->> related
|
|
(reduce (fn [acc pair] (into acc (get-related-ids context pair)))
|
|
related)
|
|
(remove (fn [[_ id]] (= id uuid/zero)))
|
|
set)]
|
|
(if (= expanded related)
|
|
related
|
|
(recur expanded))))
|
|
|
|
related-by-page
|
|
(reduce (fn [acc [page-id id]] (update acc page-id (fnil conj #{}) id))
|
|
{}
|
|
related)
|
|
|
|
unrelated-pages
|
|
(->> (:pages fdata)
|
|
(remove (fn [page-id] (seq (get related-by-page page-id))))
|
|
vec)
|
|
|
|
unrelated-items-by-page
|
|
(->> (:pages fdata)
|
|
(remove (set unrelated-pages))
|
|
(map (fn [page-id]
|
|
(let [page-related (get related-by-page page-id #{})
|
|
ids (->> (get pindex page-id)
|
|
:objects
|
|
keys
|
|
(remove #{uuid/zero})
|
|
(remove page-related)
|
|
set)]
|
|
[page-id ids])))
|
|
(filter (fn [[_ ids]] (seq ids)))
|
|
vec)
|
|
|
|
items-to-delete
|
|
(reduce + (map (comp count second) unrelated-items-by-page))]
|
|
|
|
(js/console.log (str "Pages to delete: " (count unrelated-pages)
|
|
", items to delete: " items-to-delete))
|
|
(.table js/console
|
|
(->> unrelated-items-by-page
|
|
(mapcat (fn [[page-id ids]]
|
|
(let [objects (-> (get pindex page-id) :objects)]
|
|
(map (fn [id]
|
|
{:page-id (str page-id)
|
|
:id (str id)
|
|
:name (:name (get objects id))})
|
|
ids))))
|
|
(clj->js)))
|
|
(when (and (or (seq unrelated-pages) (pos? items-to-delete))
|
|
(js/confirm (str "Delete " (count unrelated-pages) " unrelated page(s) and "
|
|
items-to-delete " unrelated item(s)?")))
|
|
(let [undo-id (js/Symbol)]
|
|
(apply st/emit!
|
|
(concat
|
|
[(dwu/start-undo-transaction undo-id)]
|
|
(map dw/delete-page unrelated-pages)
|
|
(map (fn [[page-id ids]]
|
|
(dw/delete-shapes page-id ids))
|
|
unrelated-items-by-page)
|
|
[(dwu/commit-undo-transaction undo-id)]))))
|
|
nil))
|