✨ Add support auto decoding and validation syntax for obj/reify

frontend/src/app/util/object.cljc

@@ -4,12 +4,17 @@
 ;;
 ;; Copyright (c) KALEIDOS INC
 
+#_: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
-   [clojure.core :as c]))
+   [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?
@@ -138,55 +143,139 @@
 
        ~constructor-sym)))
 
-(defmacro add-properties!
+#?(:clj
-  "Adds properties to an object using `.defineProperty`"
+   (defmacro add-properties!
-  [rsym & properties]
+     "Adds properties to an object using `.defineProperty`"
-  (let [rsym       (with-meta rsym {:tag 'js})
+     [rsym & properties]
-        getf-sym   (with-meta (gensym (str rsym "-get-fn-")) {:tag 'js})
+     (let [rsym       (with-meta rsym {:tag 'js})
-        setf-sym   (with-meta (gensym (str rsym "-set-fn-")) {:tag 'js})
-        this-sym   (with-meta (gensym (str rsym "-this-")) {:tag 'js})
-        target-sym (with-meta (gensym (str rsym "-target-")) {:tag 'js})]
-    `(let [~target-sym ~rsym]
-       ;; 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)
-                     this?    (c/get params :this true)
-                     enum?    (c/get params :enumerable true)
-                     conf?    (c/get params :configurable)
-                     writ?    (c/get params :writable)]]
-           `(let [~@(concat
-                     (when get-expr
-                       [getf-sym get-expr])
-                     (when set-expr
-                       [setf-sym set-expr]))]
-              (.defineProperty
-               js/Object
-               ~target-sym
-               ~pname
-               (cljs.core/js-obj
-                ~@(concat
-                   ["enumerable" (boolean enum?)]
 
-                   (when conf?
+           this-sym   (with-meta (gensym (str rsym "-this-")) {:tag 'js})
-                     ["configurable" true])
+           target-sym (with-meta (gensym (str rsym "-target-")) {:tag 'js})
 
-                   (when (some? writ?)
+           make-sym
-                     ["writable" true])
+           (fn [pname prefix]
+             (-> (gensym (str "prop-" prefix "-" (str/slug pname) "-"))
+                 (with-meta {:tag 'js})))
 
-                   (when get-expr
+           make-sym
-                     (if this?
+           (memoize make-sym)
-                       ["get" `(fn [] (cljs.core/this-as ~this-sym (~getf-sym ~this-sym)))]
-                       ["get" getf-sym]))
 
-                   (when set-expr
+           bindings
-                     (if this?
+           (->> properties
-                       ["set" `(fn [v#] (cljs.core/this-as ~this-sym (~setf-sym ~this-sym v#)))]
+                (mapcat (fn [params]
-                       ["set" setf-sym])))))))
+                          (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)
 
-       ;; Returns the object
+                                fn-sym
-       ~target-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}))
+
+                                wrap-sym
+                                (-> (gensym (str "wrap-fn-" (str/slug pname) "-"))
+                                    (with-meta {:tag 'function}))]
+
+                            (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]
+                                       (.call ~fn-sym ~this-sym ~this-sym)))
+                                  get-expr)])
+
+                             (when set-expr
+                               [(make-sym pname "set-fn")
+                                (if this?
+                                  `(fn [v#]
+                                     (let [~this-sym (~'js* "this")
+                                           ~fn-sym ~set-expr]
+                                       (.call ~fn-sym ~this-sym ~this-sym v#)))
+                                  set-expr)])
+
+                             (when fn-expr
+                               (concat
+                                (when schema-1
+                                  [coercer-sym `(sm/coercer ~schema-1)])
+                                (when schema-n
+                                  [coercer-sym `(sm/coercer ~schema-n)])
+
+                                [(make-sym pname "get-fn")
+                                 `(fn []
+                                    (let [~this-sym (~'js* "this")
+                                          ~fn-sym   ~fn-expr
+                                          ~fn-sym   ~(if this?
+                                                       `(.bind ~fn-sym ~this-sym ~this-sym)
+                                                       `(.bind ~fn-sym ~this-sym))
+
+                                          ~@(if schema-1
+                                              [fn-sym `(fn* [param#]
+                                                            (let [param# (json/->clj param#)
+                                                                  param# (~coercer-sym param#)]
+                                                              (~fn-sym param#)))]
+                                              [])
+                                          ~@(if schema-n
+                                              [fn-sym `(fn* []
+                                                            (let [params# (into-array (cljs.core/js-arguments))
+                                                                  params# (mfu/bean params#)
+                                                                  params# (~coercer-sym params#)]
+                                                              (apply ~fn-sym params#)))]
+                                              [])
+                                          ~@(if wrap
+                                              [fn-sym `(~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]
@@ -218,17 +307,20 @@
         (let [definition (first params)]
           (if (some? definition)
             (let [definition (if (map? definition)
-                               (c/merge {:this false} (assoc definition :name (name ckey)))
+                               (c/merge {:wrap (:wrap tmeta)} definition)
                                (-> {:enumerable false}
                                    (c/merge (meta definition))
-                                   (assoc :name (name ckey))
+                                   (assoc :wrap (:wrap tmeta))
-                                   (assoc :this false)
+                                   (assoc :fn definition)
-                                   (assoc :get `(fn [] ~definition))))]
+                                   (dissoc :get :set)))
+                  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})))))
 
@@ -270,23 +362,30 @@
   on demand with the ability to assign protocol implementations and
   custom properties"
   [& params]
-  (let [[tmeta properties definitions] (collect-properties params)
+  (let [[tmeta properties definitions]
-        obj-sym    (gensym "obj-")]
+        (collect-properties params)
-    `(let [~obj-sym (cljs.core/js-obj)]
-       (add-properties! ~obj-sym
-                        ~@(when-let [tname (:name tmeta)]
-                            [`{:name ~'js/Symbol.toStringTag
-                               :this false
-                               :enumerable false
-                               :get (fn [] ~tname)}
-                             `{:name type-symbol
-                               :this false
-                               :enumerable false
-                               :get (fn [] ~tname)}])
-                        ~@properties)
-       (let [~obj-sym ~(if-let [definitions (seq definitions)]
-                         `(cljs.core/specify! ~obj-sym
-                            ~@(mapcat (fn [[k v]] (cons k v)) definitions))
-                         obj-sym)]
 
-         (cljs.core/specify! ~obj-sym)))))
+        f-sym
+        (gensym "to-string-")
+
+        type-name
+        (or (c/get tmeta :name) (str (gensym "anonymous")))
+
+        obj-sym
+        (gensym "obj-")]
+
+    `(let [~obj-sym (cljs.core/js-obj)
+           ~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))))

frontend/test/frontend_tests/runner.cljs

@@ -16,6 +16,7 @@
    [frontend-tests.tokens.logic.token-actions-test]
    [frontend-tests.tokens.logic.token-data-test]
    [frontend-tests.tokens.style-dictionary-test]
+   [frontend-tests.util-object-test]
    [frontend-tests.util-range-tree-test]
    [frontend-tests.util-simple-math-test]
    [frontend-tests.worker-snap-test]))
@@ -45,6 +46,7 @@
    'frontend-tests.tokens.logic.token-actions-test
    'frontend-tests.tokens.logic.token-data-test
    'frontend-tests.tokens.style-dictionary-test
+   'frontend-tests.util-object-test
    'frontend-tests.util-range-tree-test
    'frontend-tests.util-simple-math-test
    'frontend-tests.worker-snap-test))

frontend/test/frontend_tests/util_object_test.cljs

@@ -0,0 +1,113 @@
+;; 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 frontend-tests.util-object-test
+  (:require
+   [app.common.schema :as sm]
+   [app.util.object :as obj]
+   [cljs.pprint :refer [pprint]]
+   [cljs.test :as t]))
+
+(t/deftest getters-and-setters
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :value
+              {:get (fn [] @val)
+               :set (fn [o] (vswap! val (constantly o)))})]
+
+    (t/is (nil? (.-value obj)))
+    (set! (.-value obj) 2)
+    (t/is (= 2 (.-value obj)))
+    (t/is (= 2 @val))))
+
+(t/deftest getters-and-setters-access-this
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :value
+              {:get (fn []
+                      (this-as self
+                               self))
+               :set (fn [o]
+                      (this-as self
+                               (vreset! val self)))})]
+
+    (t/is (identical? obj (.-value obj)))
+    (set! (.-value obj) 1)
+    (t/is (identical? obj @val))))
+
+(t/deftest getters-and-setters-access-explicit-this
+  (let [val1 (volatile! nil)
+        val2 (volatile! nil)
+        obj  (obj/reify {:name "Foo"}
+               :value
+               {:this true
+                :get (fn [this]
+                       (this-as self (vreset! val1 self))
+                       (vreset! val2 this)
+                       this)
+                :set (fn [this o]
+                       (this-as self (vreset! val1 self))
+                       (vreset! val2 this))})]
+
+    (t/is (identical? obj (.-value obj)))
+    (t/is (identical? obj @val1))
+    (t/is (identical? obj @val2))
+
+    (vreset! val1 nil)
+    (vreset! val2 nil)
+    (set! (.-value obj) 1)
+
+    (t/is (identical? obj @val1))
+    (t/is (identical? obj @val2))))
+
+(t/deftest functions-with-map-syntax
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :sum
+              {:fn (fn [a b]
+                     (this-as self (vreset! val self))
+                     (+ a b))})]
+
+    (t/is (= 3 (.sum obj 1 2)))
+    (t/is (identical? obj @val))))
+
+(t/deftest functions-with-short-syntax
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :sum
+              (fn [a b]
+                (this-as self (vreset! val self))
+                (+ a b)))]
+
+    (t/is (= 3 (.sum obj 1 2)))
+    (t/is (identical? obj @val))))
+
+(t/deftest functions-with-schema
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :sum
+              {:schema [:cat ::sm/int ::sm/int]
+               :fn (fn [a b]
+                     (this-as self (vreset! val self))
+                     (+ a b))})]
+    (t/is (= 3 (.sum obj 1 2)))
+    (t/is (= 3 (.sum obj 1 "2")))
+
+    (t/is (true? (.propertyIsEnumerable obj "sum")))
+    (t/is (thrown-with-msg? js/Error
+                            #"check error"
+                            (.sum obj 1 "a")))))
+
+(t/deftest non-enumerable-props
+  (let [val (volatile! nil)
+        obj (obj/reify {:name "Foo"}
+              :sum
+              {:enumerable false
+               :fn (fn [a b]
+                     (this-as self (vreset! val self))
+                     (+ a b))})]
+
+    (t/is (false? (.propertyIsEnumerable obj "sum")))))