mirror of
https://github.com/penpot/penpot.git
synced 2026-08-30 08:39:19 +00:00
506 lines
19 KiB
Clojure
506 lines
19 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 INC Sucursal en España SL
|
|
|
|
#_:clj-kondo/ignore
|
|
(ns app.util.object
|
|
"A collection of helpers for work with javascript objects."
|
|
(:refer-clojure :exclude [set! new get merge clone contains? array? into-array reify class])
|
|
#?(:cljs (:require-macros [app.util.object]))
|
|
(:require
|
|
[app.common.data :as d]
|
|
[app.common.json :as json]
|
|
[app.common.schema :as sm]
|
|
[clojure.core :as c]
|
|
[cuerdas.core :as str]
|
|
[rumext.v2.util :as mfu]))
|
|
|
|
#?(:cljs
|
|
(defn array?
|
|
[o]
|
|
(.isArray js/Array o)))
|
|
|
|
#?(:cljs
|
|
(defn into-array
|
|
[o]
|
|
(js/Array.from o)))
|
|
|
|
#?(:cljs
|
|
(defn create [] #js {}))
|
|
|
|
#?(:cljs
|
|
(defn get
|
|
([obj k]
|
|
(when (some? obj)
|
|
(unchecked-get obj k)))
|
|
([obj k default]
|
|
(let [result (get obj k)]
|
|
(if (undefined? result) default result)))))
|
|
|
|
#?(:cljs
|
|
(defn contains?
|
|
[obj k]
|
|
(when (some? obj)
|
|
(js/Object.hasOwn obj k))))
|
|
|
|
#?(:cljs
|
|
(defn clone
|
|
[a]
|
|
(js/Object.assign #js {} a)))
|
|
|
|
#?(:cljs
|
|
(defn merge!
|
|
([a b]
|
|
(js/Object.assign a b))
|
|
([a b & more]
|
|
(reduce merge! (merge! a b) more))))
|
|
|
|
#?(:cljs
|
|
(defn merge
|
|
([a b]
|
|
(js/Object.assign #js {} a b))
|
|
([a b & more]
|
|
(reduce merge! (merge a b) more))))
|
|
|
|
#?(:cljs
|
|
(defn set!
|
|
[obj key value]
|
|
(unchecked-set obj key value)
|
|
obj))
|
|
|
|
#?(:cljs
|
|
(defn unset!
|
|
[obj key]
|
|
(js-delete obj key)
|
|
obj))
|
|
|
|
#?(:cljs
|
|
(def ^:private not-found-sym
|
|
(js/Symbol "not-found")))
|
|
|
|
#?(:cljs
|
|
(defn update!
|
|
[obj key f & args]
|
|
(let [found (c/get obj key not-found-sym)]
|
|
(when-not ^boolean (identical? found not-found-sym)
|
|
(unchecked-set obj key (apply f found args)))
|
|
obj)))
|
|
|
|
#?(:cljs
|
|
(defn ^boolean in?
|
|
[obj prop]
|
|
(js* "~{} in ~{}" prop obj)))
|
|
|
|
#?(:cljs
|
|
(defn without-empty
|
|
[^js obj]
|
|
(when (some? obj)
|
|
(js* "Object.entries(~{}).reduce((a, [k,v]) => (v == null ? a : (a[k]=v, a)), {}) " obj))))
|
|
|
|
#?(:cljs
|
|
(defn plain-object?
|
|
^boolean
|
|
[o]
|
|
(and (some? o)
|
|
(identical? (.getPrototypeOf js/Object o)
|
|
(.-prototype js/Object)))))
|
|
|
|
#?(:cljs
|
|
(defn stringify
|
|
[obj]
|
|
(js/JSON.stringify obj)))
|
|
|
|
;; EXPERIMENTAL: unsafe, does not checks and not validates the input,
|
|
;; should be improved over time, for now it works for define a class
|
|
;; extending js/Error that is more than enought for a first, quick and
|
|
;; dirty macro impl for generating classes.
|
|
|
|
(defmacro class
|
|
"Create a class instance"
|
|
[& {:keys [name extends constructor]}]
|
|
|
|
(let [params
|
|
(if (and constructor (= 'fn (first constructor)))
|
|
(into [] (drop 1) (second constructor))
|
|
[])
|
|
|
|
constructor-sym
|
|
(symbol name)
|
|
|
|
constructor
|
|
(if constructor
|
|
constructor
|
|
`(fn ~name [~'this]
|
|
(.call ~extends ~'this)))]
|
|
|
|
`(let [konstructor# ~constructor
|
|
extends# ~extends
|
|
~constructor-sym
|
|
(fn ~constructor-sym ~params
|
|
(cljs.core/this-as ~'this
|
|
(konstructor# ~'this ~@params)))]
|
|
|
|
(set! (.-prototype ~constructor-sym)
|
|
(js/Object.create (.-prototype extends#)))
|
|
(set! (.-constructor (.-prototype ~constructor-sym))
|
|
konstructor#)
|
|
|
|
~constructor-sym)))
|
|
|
|
#?(:clj
|
|
(defmacro add-properties!
|
|
"Adds properties to an object using `.defineProperty`"
|
|
[rsym & properties]
|
|
(let [rsym (with-meta rsym {:tag 'js})
|
|
|
|
this-sym (with-meta (gensym (str rsym "-this-")) {:tag 'js})
|
|
target-sym (with-meta (gensym (str rsym "-target-")) {:tag 'js})
|
|
cause-sym (gensym "cause-")
|
|
|
|
make-sym
|
|
(fn [pname prefix]
|
|
(-> (gensym (str "prop-" prefix "-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'js})))
|
|
|
|
make-sym
|
|
(memoize make-sym)
|
|
|
|
bindings
|
|
(->> properties
|
|
(mapcat (fn [params]
|
|
(let [pname (c/get params :name)
|
|
get-expr (c/get params :get)
|
|
set-expr (c/get params :set)
|
|
fn-expr (c/get params :fn)
|
|
schema-n (c/get params :schema)
|
|
wrap (c/get params :wrap)
|
|
schema-1 (c/get params :schema-1)
|
|
this? (c/get params :this false)
|
|
on-error (c/get params :on-error)
|
|
|
|
decode-expr
|
|
(c/get params :decode/fn)
|
|
|
|
decode-options
|
|
(c/get params :decode/options)
|
|
|
|
decode-options
|
|
(if (and decode-expr decode-options)
|
|
(do
|
|
(println "WARN: decode/fn and decode/options are excluding, ignoring decode/options")
|
|
nil)
|
|
decode-options)
|
|
|
|
decode-expr
|
|
(or decode-expr 'app.common.json/->clj)
|
|
|
|
fn-sym
|
|
(-> (gensym (str "internal-fn-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'function}))
|
|
|
|
coercer-sym
|
|
(-> (gensym (str "coercer-fn-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'function}))
|
|
|
|
decode-sym
|
|
(-> (gensym (str "decode-fn-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'function}))
|
|
|
|
schema-sym
|
|
(-> (gensym (str "schema-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'function}))
|
|
|
|
wrap-sym
|
|
(-> (gensym (str "wrap-fn-" (str/slug pname) "-"))
|
|
(with-meta {:tag 'function}))
|
|
|
|
val-sym
|
|
(gensym (str "val-" (str/slug pname) "-"))
|
|
|
|
wrap-error-handling
|
|
(if on-error
|
|
(fn [expr]
|
|
`(try
|
|
~expr
|
|
(catch :default ~cause-sym
|
|
(~on-error ~cause-sym))))
|
|
identity)]
|
|
|
|
(concat
|
|
(when wrap
|
|
[wrap-sym wrap])
|
|
|
|
(when get-expr
|
|
[(make-sym pname "get-fn")
|
|
(if this?
|
|
`(fn []
|
|
(let [~this-sym (~'js* "this")
|
|
~fn-sym ~get-expr]
|
|
~(wrap-error-handling
|
|
`(.call ~fn-sym ~this-sym ~this-sym))))
|
|
`(fn []
|
|
(let [~this-sym (~'js* "this")
|
|
~fn-sym ~get-expr]
|
|
~(wrap-error-handling
|
|
`(.call ~fn-sym ~this-sym)))))])
|
|
|
|
(when set-expr
|
|
[schema-sym schema-n
|
|
|
|
coercer-sym `(if (and (some? ~schema-sym)
|
|
(not (fn? ~schema-sym)))
|
|
(sm/coercer ~schema-sym)
|
|
nil)
|
|
|
|
decode-sym decode-expr
|
|
|
|
(make-sym pname "set-fn")
|
|
`(fn [~val-sym]
|
|
~(wrap-error-handling
|
|
`(let [~this-sym (~'js* "this")
|
|
~fn-sym ~set-expr
|
|
|
|
;; We only emit schema and coercer bindings if
|
|
;; schema-n is provided
|
|
~@(if (some? schema-n)
|
|
[schema-sym
|
|
`(if (fn? ~schema-sym)
|
|
(~schema-sym ~val-sym)
|
|
~schema-sym)
|
|
|
|
coercer-sym
|
|
`(if (nil? ~coercer-sym)
|
|
(sm/coercer ~schema-sym)
|
|
~coercer-sym)
|
|
|
|
val-sym
|
|
(if (not= decode-expr 'app.common.json/->clj)
|
|
`(~decode-sym ~val-sym)
|
|
`(~decode-sym ~val-sym ~decode-options))
|
|
|
|
val-sym
|
|
`(~coercer-sym ~val-sym)]
|
|
[])]
|
|
|
|
~(if this?
|
|
`(.call ~fn-sym ~this-sym ~this-sym ~val-sym)
|
|
`(.call ~fn-sym ~this-sym ~val-sym)))))])
|
|
|
|
(when fn-expr
|
|
[schema-sym (or schema-n schema-1)
|
|
coercer-sym `(if (and (some? ~schema-sym)
|
|
(not (fn? ~schema-sym)))
|
|
(sm/coercer ~schema-sym)
|
|
nil)
|
|
decode-sym decode-expr
|
|
|
|
(make-sym pname "get-fn")
|
|
`(fn []
|
|
(let [~this-sym (~'js* "this")
|
|
~fn-sym ~(if (and (list? fn-expr)
|
|
(= 'fn (first fn-expr)))
|
|
(let [[sa sb & sother] fn-expr]
|
|
`(~sa ~sb ~(wrap-error-handling `(do ~@sother))))
|
|
fn-expr)
|
|
|
|
~fn-sym ~(if this?
|
|
`(.bind ~fn-sym ~this-sym ~this-sym)
|
|
`(.bind ~fn-sym ~this-sym))
|
|
|
|
;; We only emit schema and coercer bindings if
|
|
;; schema-n or schema-1 is provided
|
|
~@(if (or schema-n schema-1)
|
|
[fn-sym `(fn* [~@(if schema-1 [val-sym] [])]
|
|
~(wrap-error-handling
|
|
`(let [~@(if schema-n
|
|
[val-sym `(into-array (cljs.core/js-arguments))]
|
|
[])
|
|
~val-sym
|
|
~(if (not= decode-expr 'app.common.json/->clj)
|
|
`(~decode-sym ~val-sym)
|
|
`(~decode-sym ~val-sym ~decode-options))
|
|
|
|
~schema-sym
|
|
(if (fn? ~schema-sym)
|
|
(~schema-sym ~val-sym)
|
|
~schema-sym)
|
|
|
|
~coercer-sym
|
|
(if (nil? ~coercer-sym)
|
|
(sm/coercer ~schema-sym)
|
|
~coercer-sym)
|
|
|
|
~val-sym
|
|
(~coercer-sym ~val-sym)]
|
|
|
|
~(if schema-1
|
|
`(~fn-sym ~val-sym)
|
|
`(apply ~fn-sym ~val-sym)))))]
|
|
[])]
|
|
~(if wrap
|
|
`(~wrap-sym ~fn-sym)
|
|
fn-sym)))]))))))]
|
|
|
|
`(let [~target-sym ~rsym
|
|
~@bindings]
|
|
;; Creates the `.defineProperty` per property
|
|
~@(for [params properties
|
|
:let [pname (c/get params :name)
|
|
get-expr (c/get params :get)
|
|
set-expr (c/get params :set)
|
|
fn-expr (c/get params :fn)
|
|
enum? (c/get params :enumerable true)
|
|
conf? (c/get params :configurable)
|
|
writ? (c/get params :writable)]]
|
|
`(.defineProperty
|
|
js/Object
|
|
~target-sym
|
|
~pname
|
|
(cljs.core/js-obj
|
|
~@(concat
|
|
["enumerable" (boolean enum?)]
|
|
|
|
(when conf?
|
|
["configurable" true])
|
|
|
|
(when (some? writ?)
|
|
["writable" true])
|
|
|
|
(when (or get-expr)
|
|
["get" (make-sym pname "get-fn")])
|
|
|
|
(when fn-expr
|
|
["get" (make-sym pname "get-fn")])
|
|
|
|
(when set-expr
|
|
["set" (make-sym pname "set-fn")])))))
|
|
|
|
;; Returns the object
|
|
~target-sym))))
|
|
|
|
(defn- collect-properties
|
|
[params]
|
|
(let [[tmeta params] (if (map? (first params))
|
|
[(first params) (rest params)]
|
|
[{} params])]
|
|
(loop [params (seq params)
|
|
props []
|
|
defs {}
|
|
curr :start
|
|
ckey nil]
|
|
(cond
|
|
(= curr :start)
|
|
(let [candidate (first params)]
|
|
(cond
|
|
(keyword? candidate)
|
|
(recur (rest params) props defs :property candidate)
|
|
|
|
(nil? candidate)
|
|
(recur (rest params) props defs :end nil)
|
|
|
|
:else
|
|
(recur (rest params) props defs :definition candidate)))
|
|
|
|
(= :end curr)
|
|
[tmeta props defs]
|
|
|
|
(= :property curr)
|
|
(let [definition (first params)]
|
|
(if (some? definition)
|
|
(let [definition (if (map? definition)
|
|
(c/merge {:wrap (:wrap tmeta)
|
|
:on-error (:on-error tmeta)}
|
|
definition)
|
|
(-> {:enumerable false}
|
|
(c/merge (meta definition))
|
|
(assoc :wrap (:wrap tmeta))
|
|
(assoc :on-error (:on-error tmeta))
|
|
(assoc :fn definition)
|
|
(dissoc :get :set :line :column)
|
|
(d/without-nils)))
|
|
definition (assoc definition :name (name ckey))]
|
|
|
|
(recur (rest params)
|
|
(conj props definition)
|
|
defs
|
|
:start
|
|
nil))
|
|
|
|
(let [hint (str "expected property definition for: " curr)]
|
|
(throw (ex-info hint {:key curr})))))
|
|
|
|
(= :definition curr)
|
|
(let [[params props defs curr ckey]
|
|
(loop [params params
|
|
defs (update defs ckey #(or % []))]
|
|
(let [candidate (first params)
|
|
params (rest params)]
|
|
(cond
|
|
(nil? candidate)
|
|
[params props defs :end]
|
|
|
|
(keyword? candidate)
|
|
[params props defs :property candidate]
|
|
|
|
(symbol? candidate)
|
|
[params props defs :definition candidate]
|
|
|
|
:else
|
|
(recur params (update defs ckey conj candidate)))))]
|
|
(recur params props defs curr ckey))
|
|
|
|
:else
|
|
(throw (ex-info "invalid params" {}))))))
|
|
|
|
#?(:cljs
|
|
(def type-symbol
|
|
(js/Symbol.for "penpot.reify:type")))
|
|
|
|
#?(:cljs
|
|
(defn type-of?
|
|
[o t]
|
|
(let [o (get o type-symbol)]
|
|
(= o t))))
|
|
|
|
#?(:cljs
|
|
(def Proxy
|
|
(app.util.object/class
|
|
:name "Proxy"
|
|
:extends js/Object
|
|
:constructor (constantly nil))))
|
|
|
|
(defmacro reify
|
|
"A domain specific variation of reify that creates anonymous objects
|
|
on demand with the ability to assign protocol implementations and
|
|
custom properties"
|
|
[& params]
|
|
(let [[tmeta properties definitions]
|
|
(collect-properties params)
|
|
|
|
f-sym
|
|
(gensym "to-string-")
|
|
|
|
type-name
|
|
(or (c/get tmeta :name) (str (gensym "anonymous")))
|
|
|
|
obj-sym
|
|
(gensym "obj-")]
|
|
|
|
`(let [~obj-sym (new Proxy)
|
|
~f-sym (fn [] ~type-name)]
|
|
(add-properties! ~obj-sym
|
|
{:name ~'js/Symbol.toStringTag
|
|
:enumerable false
|
|
:get ~f-sym}
|
|
{:name (js/Symbol.for "penpot.reify:type")
|
|
:enumerable false
|
|
:get ~f-sym}
|
|
~@properties)
|
|
|
|
~(if-let [definitions (seq definitions)]
|
|
`(cljs.core/specify! ~obj-sym
|
|
~@(mapcat (fn [[k v]] (cons k v)) definitions))
|
|
obj-sym))))
|