[wip] Validate & destructure parts, including passed-in functions

kimo-k · kimo-k · commit 6f2e24334ad2 · 2025-01-31T08:02:26.000+01:00
diff --git a/.cljfmt.edn b/.cljfmt.edn
@@ -1 +1,2 @@
-{:extra-indents {re-com.util/part [[:inner 0]]}}
+{:extra-indents {re-com.util/part [[:inner 0]]
+                 part             [[:inner 0]]}}
diff --git a/src/re_com/nested_v_grid.cljs b/src/re_com/nested_v_grid.cljs
diff --git a/src/re_com/nested_v_grid/parts.cljs b/src/re_com/nested_v_grid/parts.cljs
@@ -13,7 +13,7 @@
 (defn header-label [{:keys [path]}]
   (let [spec (peek path)]
     (or (:label spec)
-        (some-> spec :id name)
+        (some-> spec :id str)
         (some-> spec pr-str))))
 
 (def row-header-label header-label)
diff --git a/src/re_com/part.cljs b/src/re_com/part.cljs
@@ -0,0 +1,148 @@
+(ns re-com.part
+  (:refer-clojure :exclude [name get])
+  (:require
+   [clojure.set :as set]
+   [clojure.string :as str]
+   [re-com.theme.util :as tu]
+   [re-com.validate :as validate]
+   [re-com.util :as u]))
+
+(def id first)
+
+(defn children [[a & [b & rest-children :as all-children]]]
+  (if (map? b)
+    rest-children
+    all-children))
+
+(def branch? sequential?)
+
+(def unqualify (memoize (comp keyword clojure.core/name)))
+
+(def depth
+  (memoize
+   (fn depth [tree k]
+     (let [walk (fn walk [node depth]
+                  (cond
+                    (= (unqualify k)
+                       (unqualify (id node)))
+                    depth
+                    (branch? node)
+                    (some #(walk % (inc depth)) (children node))))]
+       (walk tree 1)))))
+
+(defn props [[_ b]]
+  (when (map? b) b))
+
+(def top-level-args
+  (fn [structure]
+    (->> structure
+         (tree-seq branch? children)
+         (filter (comp :top-level-arg? props))
+         (map id)
+         (mapcat (fn [k]
+                   [#_k ;;TODO support qualified keys?
+                    (unqualify k)]))
+         set)))
+
+(defn css-class [part-id]
+  (str "rc-"
+       (subs (namespace part-id) 7)
+       "-"
+       (clojure.core/name part-id)))
+
+(def describe
+  (memoize
+   (fn describe [structure]
+     (->> structure
+          (tree-seq branch? children)
+          (mapv (fn [node]
+                  (let [part-id            (id node)
+                        part-name          (unqualify part-id)
+                        {:keys [tag impl]
+                         :as part-props} (props node)]
+                    (merge
+                     part-props
+                     {:name  part-name
+                      :class (css-class part-id)
+                      :level (depth structure part-name)
+                      :impl  (or (when impl (-> (ns-name impl)
+                                                (str/replace "$" ".")
+                                                (str/replace "_" "-")))
+                                 (when tag (str "[" tag "]"))
+                                 "[:div]")}))))))))
+
+(def top-level-arg?
+  (memoize
+   (fn [structure k]
+     (contains? (top-level-args structure) k))))
+
+(defn unqualify-set [s] (set (map unqualify s)))
+
+(defn args-valid? [part-structure args problems]
+  (let [part-seq  (tree-seq branch? children part-structure)
+        ks        (unqualify-set (map id part-seq))
+        top-ks    (unqualify-set (top-level-args part-structure))
+        top-args  (set (filter top-ks (keys args)))
+        part-args (set (filter ks (keys (:parts args))))
+        top-level-collisions
+        (->> (unqualify-set top-args)
+             (set/intersection (unqualify-set part-args))
+             (map #(do {:problem  :part-top-level-collision
+                        :arg-name %})))
+        top-level-unsupported-keys
+        (->> (set (keys args))
+             (set/intersection ks)
+             (remove top-ks)
+             (map #(do {:problem  :part-top-level-unsupported
+                        :arg-name %})))]
+    (vec (concat problems
+                 top-level-collisions
+                 top-level-unsupported-keys))))
+
+(def part? (some-fn map? string? vector? ifn? nil?))
+
+(defn describe-args [structure]
+  (into [{:name              :parts
+          :required          false
+          :type              "map"
+          :parts-validate-fn (validate/parts?
+                              (set (map :name (describe structure))))
+          :description       "See Parts section below."}]
+        (comp
+         (filter (comp (top-level-args structure) :name))
+         (map #(merge % {:validate-fn part?})))
+        (describe structure)))
+
+(defn destructure [part-structure props k]
+  (or (when (top-level-arg? part-structure k)
+        (clojure.core/get props (unqualify k)))
+      (clojure.core/get-in props [:parts (unqualify k)])))
+
+(defn default [{:keys [class style attr children tag]
+                :or   {tag :div}}]
+  (into [tag (merge {:class class :style style} attr)]
+        children))
+
+(defn part
+  ([structure props k opts]
+   (part (destructure structure props k)
+     (assoc opts :part k)))
+  ([part-value {:keys   [impl key theme post-props props]
+                part-id :part
+                :or     {impl default}}]
+   (cond->
+    (cond
+      (u/hiccup? part-value) part-value
+      (string? part-value)   part-value
+      :else                  (let [component (cond (map? part-value) impl
+                                                   (ifn? part-value) part-value
+                                                   :else             impl)
+                                   props
+                                   (cond-> {:part part-id}
+                                     :do               (merge props)
+                                     theme             (theme component)
+                                     (map? part-value) (tu/merge-props part-value)
+                                     post-props        (tu/merge-props post-props))]
+                               [component props]))
+     key (with-meta {:key key}))))
+
diff --git a/src/re_com/theme.cljs b/src/re_com/theme.cljs
@@ -2,6 +2,7 @@
   (:refer-clojure :exclude [comp])
   (:require
    [re-com.theme.util :as tu]
+   [re-com.part :as part]
    [re-com.theme.default :as theme.default]))
 
 (def ^:dynamic variables theme.default/variables)
@@ -16,11 +17,7 @@
 (def merge-props tu/merge-props)
 
 (defn part-class [{:keys [part] :as props}]
-  (update props :class merge-class
-          (str "rc-"
-               (subs (namespace part) 7)
-               "-"
-               (name part))))
+  (update props :class merge-class (part/css-class part)))
 
 (def part-class* (memoize part-class))
 
diff --git a/src/re_com/validate.cljs b/src/re_com/validate.cljs
@@ -4,10 +4,10 @@
   (:require
    [clojure.string :as str]
    [cljs-time.core         :as    time.core]
-   [clojure.set            :refer [superset?]]
+   [clojure.set            :refer [superset? intersection union difference]]
    [re-com.config          :refer [debug?]]
    [re-com.debug           :as    debug]
-   [re-com.util            :refer [deref-or-value-peek]]
+   [re-com.util            :as u :refer [deref-or-value-peek]]
    [reagent.core           :as    reagent]
    [reagent.impl.component :as    component]
    [reagent.impl.template  :refer [valid-tag?]]
@@ -34,14 +34,17 @@
 (defn extract-arg-data
   "Package up all the relevant data for validation purposes from the xxx-args-desc map into a new map"
   [args-desc]
-  {:arg-names      (set (map :name args-desc))
-   :required-args  (->> args-desc
-                        (filter :required)
-                        (map :name)
-                        set)
-   :validated-args (->> (filter :validate-fn args-desc)
-                        vec
-                        (hash-map-with-name-keys))})
+  (merge
+   {:arg-names      (set (map :name args-desc))
+    :required-args  (->> args-desc
+                         (filter :required)
+                         (map :name)
+                         set)
+    :validated-args (->> (filter :validate-fn args-desc)
+                         vec
+                         (hash-map-with-name-keys))}
+   (when-let [parts-validate-fn (some :parts-validate-fn args-desc)]
+     {:parts-validate-fn parts-validate-fn})))
 
 ;; ----------------------------------------------------------------------------
 ;; Primary validation functions
@@ -119,7 +122,9 @@
                                 warning?)
                            (do
                              (log-warning
-                              (str "Validation failed for argument '" arg-name "' in component '" (component/component-name (reagent/current-component)) "': " (:message validate-result)))
+                              (str "Validation failed for argument '" arg-name "' in component '"
+                                   (component/component-name (reagent/current-component))
+                                   "': " (:message validate-result)))
                              nil)
 
                            :else
@@ -148,12 +153,16 @@
   [arg-defs passed-args]
   (if-not debug?
     nil
-    (let [passed-arg-keys (set (remove #{:theme :re-com :part} (set (keys passed-args))))
-          problems        (->> []
-                               (arg-names-known? (:arg-names arg-defs) passed-arg-keys)
-                               (required-args?   (:required-args arg-defs) passed-arg-keys)
-                               (validate-fns?    (:validated-args arg-defs) passed-args)
-                               (remove nil?))]
+    (let [{:keys [parts-validate-fn]} arg-defs
+          passed-arg-keys             (set (remove #{:theme :re-com :part} (set (keys passed-args))))
+          problems                    (as-> [] problems
+                                        (cond-> problems
+                                          parts-validate-fn
+                                          (parts-validate-fn passed-args problems))
+                                        (arg-names-known? (:arg-names arg-defs) passed-arg-keys problems)
+                                        (required-args?   (:required-args arg-defs) passed-arg-keys problems)
+                                        (validate-fns?    (:validated-args arg-defs) passed-args problems)
+                                        (remove nil? problems))]
       (when-not (empty? problems)
         [debug/validate-args-error
          :problems  problems
@@ -439,14 +448,10 @@
                  {:status  (if (or contains-class? contains-style?) :error :warning)
                   :message result}))))))
 
-(defn part?
-  "Returns true if the passed argument is a part, otherwise false/error"
-  [arg]
-  (or (map? arg) (string-or-hiccup? arg) (ifn? arg) (nil? arg)))
+(def part? (some-fn map? string? vector? ifn? nil?))
 
 (defn parts?
-  "Returns a function that validates a value is a map that contains `keys` mapped to values that are either functions, hiccups, or maps containing
-   `class`, `:style` and/or `:attr`."
+  "Returns a function that validates a value is a map that contains `keys` mapped to part-values. A part-value can be either a function, a hiccup, a string, or a parts-map. A parts-map can only contain the keys `class`, `:style` and/or `:attr`."
   [part-keys]
   {:pre [(set? part-keys)]}
   (fn [arg]
diff --git a/src/re_demo/nested_grid.cljs b/src/re_demo/nested_grid.cljs
@@ -10,7 +10,7 @@
    [reagent.core :as r]
    [re-com.nested-grid :refer [nested-grid leaf-paths header-spec->header-paths
                                nested-grid-args-desc nested-grid-parts-desc]]
-   [re-com.nested-v-grid  :as v-grid :refer [nested-v-grid]]
+   [re-com.nested-v-grid  :as nvg :refer [nested-v-grid]]
    [re-demo.utils :refer [source-reference panel-title title2 title3 args-table parts-table github-hyperlink status-text new-in-version]]))
 
 (def arg-style {:style {:display     "inline-block"
@@ -938,21 +938,26 @@
                     :on-export-corner-header export-cell
                     :on-resize               (fn [{:keys [header-dimension size-dimension keypath size]}]
                                                (case [header-dimension size-dimension]
-                                                 [:column :height] (swap! column-header-heights assoc-in keypath size)
-                                                 [:row :width]     (swap! row-header-widths assoc-in keypath size)
-                                                 [:row :height]    (swap! row-tree update-in keypath assoc :size size)
-                                                 [:column :width]  (swap! column-tree update-in keypath assoc :size size)))
+                                                 [:column :height]
+                                                 (swap! column-header-heights assoc-in keypath size)
+                                                 [:row :width]
+                                                 (swap! row-header-widths assoc-in keypath size)
+                                                 [:row :height]
+                                                 (swap! row-tree update-in keypath assoc :size size)
+                                                 [:column :width]
+                                                 (swap! column-tree update-in keypath assoc :size size)))
                     :parts                   {:wrapper {:style {:height @wh
                                                                 :width  @ww}}
 
                                               :row-header-label
-                                              (fn [{:keys [row-path]}]
-                                                (let [{:keys [is-after?]} (meta row-path)
-                                                      row-spec            (peek row-path)
-                                                      the-label           (->> "placeholder"
-                                                                               (get row-spec :id)
-                                                                               (get row-spec :label))]
-                                                  (str the-label (when is-after? " (Total)"))))
+                                              (fn [{:keys [row-path style]}]
+                                                [:div {:style style}
+                                                 (let [{:keys [is-after?]} (meta row-path)
+                                                       row-spec            (peek row-path)
+                                                       the-label           (->> "placeholder"
+                                                                                (get row-spec :id)
+                                                                                (get row-spec :label))]
+                                                   (str the-label (when is-after? " (Total)")))])
                                               :corner-header
                                               (fn [{:keys [edge row-index column-index style class attr] :as props}]
                                                 [:div (merge {:style style :class class} attr)
@@ -1062,4 +1067,5 @@
              :on-change #(reset! !tab-id %)]
             [(:view @!tab)]]]
           [demos]]]
-        [parts-table "nested-grid" nested-grid-parts-desc]]])))
+        #_[parts-table "nested-grid" nested-grid-parts-desc]
+        [parts-table "nested-v-grid" nvg/nested-v-grid-parts-desc]]])))
diff --git a/test/re_com/part_test.cljs b/test/re_com/part_test.cljs
@@ -0,0 +1,69 @@
+(ns re-com.part-test
+  (:require
+   [cljs.test :refer-macros [is are deftest]]
+   [re-com.part :as part]
+   [re-com.validate :as validate]))
+
+(def structure
+  [::wrapper
+   [::cell-grid
+    [::cell {:top-level-arg? true}
+     [::cell-label]]]])
+
+(deftest depth
+  (is (= 1 (part/depth structure ::wrapper)))
+  (is (= 4 (part/depth structure ::cell-label))))
+
+(deftest tree-walk
+  (is (= (tree-seq part/branch? part/children structure)
+         '([::wrapper
+            [::cell-grid
+             [::cell {:top-level-arg? true}
+              [::cell-label]]]]
+           [::cell-grid
+            [::cell {:top-level-arg? true}
+             [::cell-label]]]
+           [::cell {:top-level-arg? true}
+            [::cell-label]]
+           [::cell-label]))))
+
+(deftest get-part
+  (let [get-part (partial part/destructure structure)]
+    (are [props k] (get-part props k)
+      {:parts {:wrapper true}} :wrapper
+      {:parts {:wrapper true}} :wrapper
+      {:cell true}             :cell)
+    (is (= [true true true true]
+           [(part/top-level-arg? structure :cell)
+            (get-part {:cell true} :cell)
+            (not (part/top-level-arg? structure :wrapper))
+            (not
+             (get-part {:wrapper true} :wrapper))])
+        "The getter function looks in a component's top-level keys,
+         but only when :top-level-arg? is explicitly declared in the part structure.")))
+
+(deftest describe
+  (is (= (part/describe structure)
+         [{:name :wrapper, :class "rc-part-test-wrapper", :level 1, :impl "[:div]"}
+          {:name :cell-grid, :class "rc-part-test-cell-grid", :level 2, :impl "[:div]"}
+          {:name :cell, :class "rc-part-test-cell", :level 3, :impl "[:div]"}
+          {:name :cell-label, :class "rc-part-test-cell-label", :level 4, :impl "[:div]"}])))
+
+(deftest validate-props
+  (are [props problems]
+       (= (validate/part-keys-valid? structure props [])
+          problems)
+    {:cell true}             []
+    {:parts {:cell true}}    []
+    {:parts {:wrapper true}} []
+    {:cell  true
+     :parts {:cell true}}    [{:problem  :part-top-level-collision
+                               :arg-name :cell}]
+    {:wrapper true}          [{:problem  :part-top-level-unsupported
+                               :arg-name :wrapper}]
+    {:wrapper true
+     :cell    true
+     :parts   {:cell true}}  [{:problem  :part-top-level-collision
+                               :arg-name :cell}
+                              {:problem  :part-top-level-unsupported
+                               :arg-name :wrapper}]))

Original file line number	Diff line number	Diff line change
`@@ -1 +1,2 @@`
`1`		`-{:extra-indents {re-com.util/part [[:inner 0]]}}`
	`1`	`+{:extra-indents {re-com.util/part [[:inner 0]]`
	`2`	`+ part [[:inner 0]]}}`