mirror of
https://github.com/penpot/penpot.git
synced 2025-08-03 13:48:31 +02:00
508 lines
21 KiB
Clojure
508 lines
21 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
|
|
|
|
(ns app.common.record
|
|
"A collection of helpers and macros for defien a penpot customized record types."
|
|
(:refer-clojure :exclude [defrecord assoc! clone])
|
|
#?(:cljs (:require-macros [app.common.record]))
|
|
#?(:clj
|
|
(:import java.util.Map$Entry)))
|
|
|
|
#_:clj-kondo/ignore
|
|
(defmacro caching-hash
|
|
[coll hash-fn hash-key]
|
|
`(let [h# ~hash-key]
|
|
(if-not (nil? h#)
|
|
h#
|
|
(let [h# (~hash-fn ~coll)]
|
|
(set! ~hash-key h#)
|
|
h#))))
|
|
|
|
#?(:clj
|
|
(defn- property-symbol
|
|
[sym]
|
|
(symbol (str "-" (name sym)))))
|
|
|
|
#?(:clj
|
|
(defn- generate-field-access
|
|
[this-sym val-sym fields]
|
|
(map (fn [field]
|
|
(cond
|
|
(nil? field) nil
|
|
(identical? field val-sym) val-sym
|
|
:else `(. ~this-sym ~(property-symbol field))))
|
|
fields)))
|
|
|
|
|
|
(defprotocol ICustomRecordEquiv
|
|
(-equiv-with-exceptions [_ other exceptions]))
|
|
|
|
#?(:clj
|
|
(defn emit-impl-js
|
|
[tagname base-fields]
|
|
(let [fields (conj base-fields '$meta '$extmap (with-meta '$hash {:mutable true}))
|
|
key-sym (gensym "key-")
|
|
val-sym (gensym "val-")
|
|
othr-sym (with-meta 'other {:tag tagname})
|
|
this-sym (with-meta 'this {:tag tagname})]
|
|
['cljs.core/IRecord
|
|
'cljs.core/ICloneable
|
|
`(~'-clone [~this-sym]
|
|
(new ~tagname ~@(generate-field-access this-sym val-sym fields)))
|
|
|
|
'cljs.core/IHash
|
|
`(~'-hash [~this-sym]
|
|
(caching-hash ~this-sym
|
|
(fn [coll#]
|
|
(bit-xor
|
|
~(hash (str tagname))
|
|
(cljs.core/hash-unordered-coll coll#)))
|
|
(. ~this-sym ~'-$hash)))
|
|
|
|
'cljs.core/IEquiv
|
|
`(~'-equiv [~this-sym ~othr-sym]
|
|
(or (identical? ~this-sym ~othr-sym)
|
|
(and (some? ~othr-sym)
|
|
(identical? (.-constructor ~this-sym)
|
|
(.-constructor ~othr-sym))
|
|
~@(map (fn [field]
|
|
`(= (.. ~this-sym ~(property-symbol field))
|
|
(.. ~(with-meta othr-sym {:tag tagname}) ~(property-symbol field))))
|
|
base-fields)
|
|
|
|
(= (. ~this-sym ~'-$extmap)
|
|
(. ~(with-meta othr-sym {:tag tagname}) ~'-$extmap)))))
|
|
|
|
`ICustomRecordEquiv
|
|
`(~'-equiv-with-exceptions [~this-sym ~othr-sym ~'exceptions]
|
|
(or (identical? ~this-sym ~othr-sym)
|
|
(and (some? ~othr-sym)
|
|
(identical? (.-constructor ~this-sym)
|
|
(.-constructor ~othr-sym))
|
|
(and ~@(->> base-fields
|
|
(map (fn [field]
|
|
`(= (.. ~this-sym ~(property-symbol field))
|
|
(.. ~(with-meta othr-sym {:tag tagname}) ~(property-symbol field))))))
|
|
(== (count (. ~this-sym ~'-$extmap))
|
|
(count (. ~othr-sym ~'-$extmap))))
|
|
|
|
(reduce-kv (fn [~'_ ~'k ~'v]
|
|
(if (contains? ~'exceptions ~'k)
|
|
true
|
|
(if (= (get (. ~this-sym ~'-$extmap) ~'k ::not-exists) ~'v)
|
|
true
|
|
(reduced false))))
|
|
true
|
|
(. ~othr-sym ~'-$extmap)))))
|
|
|
|
|
|
'cljs.core/IMeta
|
|
`(~'-meta [~this-sym] (. ~this-sym ~'-$meta))
|
|
|
|
'cljs.core/IWithMeta
|
|
`(~'-with-meta [~this-sym ~val-sym]
|
|
(new ~tagname ~@(->> (replace {'$meta val-sym} fields)
|
|
(generate-field-access this-sym val-sym))))
|
|
|
|
'cljs.core/ILookup
|
|
`(~'-lookup [~this-sym k#]
|
|
(cljs.core/-lookup ~this-sym k# nil))
|
|
|
|
`(~'-lookup [~this-sym ~key-sym else#]
|
|
(case ~key-sym
|
|
~@(mapcat (fn [f] [(keyword f) `(. ~this-sym ~(property-symbol f))])
|
|
base-fields)
|
|
(cljs.core/get (. ~this-sym ~'-$extmap) ~key-sym else#)))
|
|
|
|
'cljs.core/ICounted
|
|
`(~'-count [~this-sym]
|
|
(+ ~(count base-fields) (count (. ~this-sym ~'-$extmap))))
|
|
|
|
'cljs.core/ICollection
|
|
`(~'-conj [~this-sym ~val-sym]
|
|
(if (vector? ~val-sym)
|
|
(cljs.core/-assoc ~this-sym (cljs.core/-nth ~val-sym 0) (cljs.core/-nth ~val-sym 1))
|
|
(reduce cljs.core/-conj ~this-sym ~val-sym)))
|
|
|
|
'cljs.core/IAssociative
|
|
`(~'-contains-key? [~this-sym ~key-sym]
|
|
~(if (seq base-fields)
|
|
`(case ~key-sym
|
|
(~@(map keyword base-fields)) true
|
|
(contains? (. ~this-sym ~'-$extmap) ~key-sym))
|
|
`(contains? (. ~this-sym ~'-$extmap) ~key-sym)))
|
|
|
|
`(~'-assoc [~this-sym ~key-sym ~val-sym]
|
|
(case ~key-sym
|
|
~@(mapcat (fn [fld]
|
|
[(keyword fld) `(new ~tagname ~@(->> (replace {fld val-sym '$hash nil} fields)
|
|
(generate-field-access this-sym val-sym)))])
|
|
base-fields)
|
|
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
|
|
(generate-field-access this-sym val-sym))
|
|
(assoc (. ~this-sym ~'-$extmap) ~key-sym ~val-sym) nil)))
|
|
|
|
'cljs.core/ITransientAssociative
|
|
`(~'-assoc! [~this-sym ~key-sym ~val-sym]
|
|
(let [key# (if (keyword? ~key-sym)
|
|
(.-fqn ~(with-meta key-sym {:tag `cljs.core/Keyword}))
|
|
~key-sym)]
|
|
(case ~key-sym
|
|
~@(mapcat
|
|
(fn [f]
|
|
[(keyword f) `(set! (. ~this-sym ~(property-symbol f)) ~val-sym)])
|
|
base-fields)
|
|
|
|
(set! (. ~this-sym ~'-$extmap) (cljs.core/assoc (. ~this-sym ~'-$extmap) ~key-sym ~val-sym)))
|
|
|
|
~this-sym))
|
|
|
|
'cljs.core/IMap
|
|
`(~'-dissoc [~this-sym ~key-sym]
|
|
(case ~key-sym
|
|
(~@(map keyword base-fields))
|
|
(cljs.core/-assoc ~this-sym ~key-sym nil)
|
|
|
|
(let [extmap1# (. ~this-sym ~'-$extmap)
|
|
extmap2# (dissoc extmap1# ~key-sym)]
|
|
(if (identical? extmap1# extmap2#)
|
|
~this-sym
|
|
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
|
|
(generate-field-access this-sym val-sym))
|
|
(not-empty extmap2#)
|
|
nil)))))
|
|
|
|
'cljs.core/ISeqable
|
|
`(~'-seq [~this-sym]
|
|
(seq (concat [~@(map (fn [f]
|
|
`(cljs.core/MapEntry.
|
|
~(keyword f)
|
|
(. ~this-sym ~(property-symbol f))
|
|
nil))
|
|
base-fields)]
|
|
(. ~this-sym ~'-$extmap))))
|
|
|
|
'cljs.core/IIterable
|
|
`(~'-iterator [~this-sym]
|
|
(cljs.core/RecordIter. 0 ~this-sym ~(count base-fields)
|
|
[~@(map keyword base-fields)]
|
|
(if (. ~this-sym ~'-$extmap)
|
|
(cljs.core/-iterator (. ~this-sym ~'-$extmap))
|
|
(cljs.core/nil-iter))))
|
|
|
|
'cljs.core/IKVReduce
|
|
`(~'-kv-reduce [~this-sym f# init#]
|
|
(reduce (fn [ret# [~key-sym v#]] (f# ret# ~key-sym v#)) init# ~this-sym))])))
|
|
|
|
#?(:clj
|
|
(defn emit-impl-jvm
|
|
[tagname base-fields]
|
|
(let [fields (conj base-fields '$meta '$extmap (with-meta '$hash {:unsynchronized-mutable true}))
|
|
key-sym 'key
|
|
val-sym 'val
|
|
this-sym (with-meta 'this {:tag tagname})]
|
|
|
|
['clojure.lang.IRecord
|
|
'clojure.lang.IPersistentMap
|
|
`(~'equiv [~this-sym ~val-sym]
|
|
(and (some? ~val-sym)
|
|
(instance? ~tagname ~val-sym)
|
|
~@(map (fn [field]
|
|
`(= (.. ~this-sym ~(property-symbol field))
|
|
(.. ~(with-meta val-sym {:tag tagname}) ~(property-symbol field))))
|
|
base-fields)
|
|
(= (. ~this-sym ~'-$extmap)
|
|
(. ~(with-meta val-sym {:tag tagname}) ~'-$extmap))))
|
|
|
|
`(~'entryAt [~this-sym ~key-sym]
|
|
(let [v# (.valAt ~this-sym ~key-sym ::not-found)]
|
|
(when (not= v# ::not-found)
|
|
(clojure.lang.MapEntry. ~key-sym v#))))
|
|
|
|
`(~'valAt [~this-sym ~key-sym]
|
|
(.valAt ~this-sym ~key-sym nil))
|
|
|
|
`(~'valAt [~this-sym ~key-sym ~'not-found]
|
|
(case ~key-sym
|
|
~@(mapcat (fn [f] [(keyword f) `(. ~this-sym ~(property-symbol f))]) base-fields)
|
|
(clojure.core/get (. ~this-sym ~'-$extmap) ~key-sym ~'not-found)))
|
|
|
|
`(~'count [~this-sym]
|
|
(+ ~(count base-fields) (count (. ~this-sym ~'-$extmap))))
|
|
|
|
|
|
`(~'empty [~this-sym]
|
|
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
|
|
(generate-field-access this-sym nil))
|
|
nil nil))
|
|
|
|
`(~'cons [~this-sym ~val-sym]
|
|
(if (instance? java.util.Map$Entry ~val-sym)
|
|
(let [^Map$Entry e# ~val-sym]
|
|
(.assoc ~this-sym (.getKey e#) (.getValue e#)))
|
|
(if (instance? clojure.lang.IPersistentVector ~val-sym)
|
|
(if (= 2 (count ~val-sym))
|
|
(.assoc ~this-sym (nth ~val-sym 0) (nth ~val-sym 1))
|
|
(throw (IllegalArgumentException.
|
|
"Vector arg to map conj must be a pair")))
|
|
(reduce (fn [^clojure.lang.IPersistentMap m#
|
|
^java.util.Map$Entry e#]
|
|
(.assoc m# (.getKey e#) (.getValue e#)))
|
|
~this-sym
|
|
~val-sym))))
|
|
|
|
`(~'assoc [~this-sym ~key-sym ~val-sym]
|
|
(case ~key-sym
|
|
~@(mapcat (fn [fld]
|
|
[(keyword fld) `(new ~tagname ~@(->> (replace {fld val-sym '$hash nil} fields)
|
|
(generate-field-access this-sym val-sym)))])
|
|
base-fields)
|
|
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
|
|
(generate-field-access this-sym val-sym))
|
|
(assoc (. ~this-sym ~'-$extmap) ~key-sym ~val-sym)
|
|
nil)))
|
|
|
|
`(~'without [~this-sym ~key-sym]
|
|
(case ~key-sym
|
|
(~@(map keyword base-fields))
|
|
(.assoc ~this-sym ~key-sym nil)
|
|
|
|
(if-let [extmap1# (. ~this-sym ~'-$extmap)]
|
|
(let [extmap2# (.without ^clojure.lang.IPersistentMap extmap1# ~key-sym)]
|
|
(if (identical? extmap1# extmap2#)
|
|
~this-sym
|
|
(new ~tagname ~@(->> (remove #{'$extmap '$hash} fields)
|
|
(generate-field-access this-sym val-sym))
|
|
(not-empty extmap2#)
|
|
nil)))
|
|
~this-sym)))
|
|
|
|
`(~'seq [~this-sym]
|
|
(seq (concat [~@(map (fn [f]
|
|
`(clojure.lang.MapEntry/create
|
|
~(keyword f)
|
|
(. ~this-sym ~(property-symbol f))))
|
|
base-fields)]
|
|
(. ~this-sym ~'-$extmap))))
|
|
|
|
`(~'iterator [~this-sym]
|
|
(clojure.lang.SeqIterator. (.seq ~this-sym)))
|
|
|
|
'clojure.lang.IFn
|
|
`(~'invoke [~this-sym ~key-sym]
|
|
(.valAt ~this-sym ~key-sym))
|
|
|
|
`(~'invoke [~this-sym ~key-sym ~'not-found]
|
|
(.valAt ~this-sym ~key-sym ~'not-found))
|
|
|
|
'java.util.Map
|
|
`(~'size [~this-sym]
|
|
(clojure.core/count ~this-sym))
|
|
|
|
`(~'containsKey [~this-sym ~key-sym]
|
|
~(if (seq base-fields)
|
|
`(case ~key-sym
|
|
(~@(map keyword base-fields)) true
|
|
(contains? (. ~this-sym ~'-$extmap) ~key-sym))
|
|
`(contains? (. ~this-sym ~'-$extmap) ~key-sym)))
|
|
|
|
`(~'isEmpty [~this-sym]
|
|
(zero? (count ~this-sym)))
|
|
|
|
`(~'keySet [~this-sym]
|
|
(throw (UnsupportedOperationException. "not implemented")))
|
|
|
|
`(~'entrySet [~this-sym]
|
|
(throw (UnsupportedOperationException. "not implemented")))
|
|
|
|
`(~'get [~this-sym ~key-sym]
|
|
(.valAt ~this-sym ~key-sym))
|
|
|
|
`(~'containsValue [~this-sym ~val-sym]
|
|
(throw (UnsupportedOperationException. "not implemented")))
|
|
|
|
`(~'values [~this-sym]
|
|
(map val (.seq ~this-sym)))
|
|
|
|
'java.lang.Object
|
|
`(~'equals [~this-sym other#]
|
|
(.equiv ~this-sym other#))
|
|
|
|
`(~'hashCode [~this-sym]
|
|
(clojure.lang.APersistentMap/mapHash ~this-sym))
|
|
|
|
'clojure.lang.IHashEq
|
|
`(~'hasheq [~this-sym]
|
|
(clojure.core/hash-unordered-coll ~this-sym))
|
|
|
|
'clojure.lang.IObj
|
|
`(~'meta [~this-sym]
|
|
(. ~this-sym ~'-$meta))
|
|
|
|
`(~'withMeta [~this-sym ~val-sym]
|
|
(new ~tagname ~@(->> (replace {'$meta val-sym} fields)
|
|
(generate-field-access this-sym val-sym))))])))
|
|
|
|
(defmacro defrecord
|
|
[rsym fields & impls]
|
|
(let [param (gensym "param-")
|
|
ks (map keyword fields)
|
|
fields' (mapv #(with-meta % nil) fields)
|
|
nsname (if (:ns &env)
|
|
(-> &env :ns :name)
|
|
(str *ns*))
|
|
ident (str "#" nsname "." (name rsym))]
|
|
|
|
`(do
|
|
(deftype ~rsym ~(into fields ['$meta '$extmap '$hash])
|
|
~@(if (:ns &env)
|
|
(emit-impl-js rsym fields')
|
|
(emit-impl-jvm rsym fields'))
|
|
~@impls
|
|
|
|
~@(when (:ns &env)
|
|
['cljs.core/IPrintWithWriter
|
|
`(~'-pr-writer [~'this writer# opts#]
|
|
(let [pr-pair# (fn [keyval#]
|
|
(cljs.core/pr-sequential-writer writer# (~'js* "cljs.core.pr_writer")
|
|
"" " " "" opts# keyval#))]
|
|
(cljs.core/pr-sequential-writer
|
|
writer# pr-pair# ~(str ident "{") ", " "}" opts#
|
|
(concat [~@(for [f fields']
|
|
`(vector ~(keyword f) (. ~'this ~(property-symbol f))))]
|
|
(. ~'this ~'-$extmap)))))]))
|
|
|
|
~@(when-not (:ns &env)
|
|
[`(defmethod print-method ~rsym [o# ^java.io.Writer w#]
|
|
(.write w# ~(str "#" nsname "." (name rsym)))
|
|
(print-method (into {} o#) w#))])
|
|
|
|
(defn ~(with-meta (symbol (str "pos->" rsym))
|
|
(assoc (meta rsym) :factory :positional))
|
|
[~@fields']
|
|
(new ~rsym ~@(conj fields nil nil nil)))
|
|
|
|
(defn ~(with-meta (symbol (str 'map-> rsym))
|
|
(assoc (meta rsym) :factory :map))
|
|
[~param]
|
|
(let [exclude# #{~@ks}
|
|
extmap# (reduce-kv (fn [acc# k# v#]
|
|
(if (contains? exclude# k#)
|
|
acc#
|
|
(assoc acc# k# v#)))
|
|
{}
|
|
~param)]
|
|
(new ~rsym
|
|
~@(for [k ks]
|
|
`(get ~param ~k))
|
|
nil
|
|
(not-empty extmap#)
|
|
nil)))
|
|
~rsym)))
|
|
|
|
(defmacro clone
|
|
[ssym]
|
|
(if (:ns &env)
|
|
`(cljs.core/clone ~ssym)
|
|
ssym))
|
|
|
|
(defmacro assoc!
|
|
"A record specific update operation"
|
|
[ssym & pairs]
|
|
(if (:ns &env)
|
|
(let [pairs (partition-all 2 pairs)]
|
|
`(-> ~ssym
|
|
~@(map (fn [[ks vs]]
|
|
`(cljs.core/-assoc! ~ks ~vs))
|
|
pairs)))
|
|
`(assoc ~ssym ~@pairs)))
|
|
|
|
(defmacro update!
|
|
"A record specific update operation"
|
|
[ssym ksym f & params]
|
|
(if (:ns &env)
|
|
(let [ssym (with-meta ssym {:tag 'js})]
|
|
`(cljs.core/assoc! ~ssym ~ksym (~f (. ~ssym ~(property-symbol ksym)) ~@params)))
|
|
`(update ~ssym ~ksym ~f ~@params)))
|
|
|
|
(defmacro define-properties!
|
|
"Define properties in the prototype with `.defineProperty`"
|
|
[rsym & properties]
|
|
(let [rsym (with-meta rsym {:tag 'js})]
|
|
`(do
|
|
~@(for [params properties
|
|
:let [pname (get params :name)
|
|
get-fn (get params :get)
|
|
set-fn (get params :set)
|
|
enum-p (get params :enumerable)
|
|
conf-p (get params :configurable)
|
|
writ-p (get params :writable)]]
|
|
`(.defineProperty js/Object (.-prototype ~rsym) ~pname
|
|
(cljs.core/js-obj
|
|
~@(concat
|
|
(if (some? enum-p)
|
|
["enumerable" enum-p]
|
|
["enumerable" true])
|
|
|
|
(if (some? conf-p)
|
|
["configurable" conf-p]
|
|
["configurable" true])
|
|
|
|
(when (some? writ-p)
|
|
["writable" writ-p])
|
|
|
|
(when get-fn
|
|
["get" get-fn])
|
|
|
|
(when set-fn
|
|
["set" set-fn]))))))))
|
|
|
|
(defmacro add-properties!
|
|
"Adds properties to an object using `.defineProperty`"
|
|
[rsym & properties]
|
|
(let [rsym (with-meta rsym {:tag 'js})
|
|
getf-sym (with-meta (gensym "get-fn") {:tag 'js})
|
|
setf-sym (with-meta (gensym "set-fn") {:tag 'js})
|
|
this-sym (with-meta (gensym "this") {:tag 'js})
|
|
target-sym (with-meta (gensym "target") {:tag 'js})]
|
|
`(let [~target-sym ~rsym]
|
|
;; Creates the `.defineProperty` per property
|
|
~@(for [params properties
|
|
:let [pname (get params :name)
|
|
get-fn (get params :get)
|
|
set-fn (get params :set)
|
|
enum-p (get params :enumerable)
|
|
conf-p (get params :configurable)
|
|
writ-p (get params :writable)]]
|
|
`(let [~getf-sym ~get-fn
|
|
~setf-sym ~set-fn]
|
|
(.defineProperty
|
|
js/Object
|
|
~target-sym
|
|
~pname
|
|
(cljs.core/js-obj
|
|
~@(concat
|
|
(if (some? enum-p)
|
|
["enumerable" enum-p]
|
|
;; Default in JS is false. We default to true
|
|
["enumerable" true])
|
|
|
|
(when (some? conf-p)
|
|
["configurable" conf-p])
|
|
|
|
(when (some? writ-p)
|
|
["writable" writ-p])
|
|
|
|
(when get-fn
|
|
["get" `(fn []
|
|
(cljs.core/this-as ~this-sym
|
|
(~getf-sym ~this-sym)))])
|
|
(when set-fn
|
|
["set" `(fn [value#]
|
|
(cljs.core/this-as ~this-sym
|
|
(~setf-sym ~this-sym value#)))]))))))
|
|
;; Returns the object
|
|
~target-sym)))
|