Skip to content

Commit

Permalink
Just one walk 🚶🏼
Browse files Browse the repository at this point in the history
  • Loading branch information
@eval
eval committed Sep 22, 2023
1 parent 5adf5eb commit bb8fbe6
Show file tree
Hide file tree
Showing 2 changed files with 95 additions and 219 deletions.
2 changes: 0 additions & 2 deletions deps.edn
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,9 +21,7 @@
:test ;; added by neil
{:extra-paths ["test"]
:extra-deps {metosin/malli {:mvn/version "0.8.9"}
#_#_io.github.camsaul/humane-are {:mvn/version "1.0.2"}
io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}
:main-opts ["-m" "cognitect.test-runner"]
:exec-fn cognitect.test-runner.api/test}
:perf {#_#_:extra-paths ["perf"]
:extra-deps {criterium/criterium {:mvn/version "0.4.6"}
Expand Down
312 changes: 95 additions & 217 deletions src/dk/thinkcreate/malli_select.clj
View file
Original file line number Diff line number Diff line change
@@ -1,27 +1,9 @@
(ns dk.thinkcreate.malli-select
"Select a subset of a malli schema."
(:require [malli.core :as m]
(:require [clojure.pprint :refer [pprint]]
[malli.core :as m]
[malli.util :as mu]))

(defn- star-or-question-selection? [sel]
(-> sel peek #{'? '*}))


(defn- question-selection? [sel]
(-> sel peek (= '?)))


(defn- star-selection? [sel]
(-> sel peek (= '*)))

;; ~4,8us
(defn- requirable-paths [schema]
(let [options {::m/walk-schema-refs true ::m/walk-refs true}
state (atom [])]
(mu/find-first schema
(fn [_ p _] (when-not (#{0 1 :malli.core/in} (peek p)) (swap! state conj p)) nil) options)
@state))


(defn- clean-path [path]
(loop [p path
Expand All @@ -34,58 +16,11 @@
(conj! r phead)))))))


(defn- path-matches-selection?
"Examples:
(path-matches-selection? [:foo] [:foo]) ;; => true
(path-matches-selection? [:foo :bar] [:foo '?]) ;; => true
(path-matches-selection? [:foo :bar] [:foo '*]) ;; => true
(path-matches-selection? [:foo :bar :baz] [:foo '*]) ;; => false"
[path sel]
(or (and (star-or-question-selection? sel)
(= (count path) (count sel))
(= (pop path) (pop sel)))
(= path sel)))


(defn- schema-path-walker [f]
(fn [schema path children _]
(f (m/-set-children schema children) path)))


;; `selector` will receive `path` (of the map).
(defn- deep-mark-paths
([schema selector] (deep-mark-paths schema selector nil))
([schema selector {:keys [all-optional?]}]
(m/walk schema
(schema-path-walker (fn [s path]
(if (= :map (m/type s))
(let [required-keys (selector path)]
(cond
all-optional? (mu/optional-keys s)
(seq required-keys) (mu/required-keys (mu/optional-keys s) required-keys)
:else (mu/optional-keys s)))
s)))
{::m/walk-schema-refs true ::m/walk-refs true})))


(defn deep-prune-optionals [schema]
(let [non-prunable-paths (atom #{})
prunable-child-path? (fn [path [name & _ :as _child]]
(not (@non-prunable-paths (conj path name))))]
(m/walk schema
(fn [s path children _options]
#_(prn :s s :path path :childre children)
(let [map-schema? (= :map (m/type s))
prunable-child? (every-pred (comp :optional second)
(partial prunable-child-path? path))
children (if map-schema? (remove prunable-child? children) children)]
(when (and map-schema? (seq children))
(let [parent-paths (take (inc (count path)) (iterate pop path))]
(swap! non-prunable-paths into parent-paths)))
(m/into-schema (m/type s) (m/-properties s) children (m/-options s))))
{::m/walk-schema-refs true ::m/walk-refs true})))


(defn- sel->map
"Turns `[:a {:b [:c]} {:b [:d]} :e]`
into `{nil [:a :e] :b [:d]}` (i.e. last `:b` wins)."
Expand Down Expand Up @@ -117,69 +52,26 @@


(defn- paths->tree [paths]
(let [f (fn [path]
(for [i (range (count path))]
[(subvec path 0 i) (nth path i)]))]
(persistent! (reduce (fn [acc [a b]]
(assoc! acc a (conj (get acc a #{}) b)))
(transient {}) (mapcat f paths)))))


(defn- schema-paths->mapper [paths]
(reduce (fn [acc sel-path]
(update acc (pop sel-path) (fnil conj '()) (peek sel-path)))
{} paths))


(defn- remove-fns-for-selection-dispatch [sel]
(cond
(question-selection? sel) :question-selection
:else :default))

(defmulti #^{:private true} remove-fns-for-selection #'remove-fns-for-selection-dispatch)

(defmethod remove-fns-for-selection :question-selection [sel]
#(path-matches-selection? % sel)
#_#(shorter-subpath? % (pop sel)))

(defmethod remove-fns-for-selection :default [_sel]
(constantly false))


(defn- filter-fns-for-selection-dispatch [sel]
(cond
(question-selection? sel) :question-selection
(star-selection? sel) :star-selection
:else :simple-selection))


(defmulti #^{:private true} filter-fns-for-selection #'filter-fns-for-selection-dispatch)
(reduce (fn [acc path]
(let [[folder name] ((juxt pop peek) path)]
(update acc folder (fnil conj #{}) name))) {} paths))

(defmethod filter-fns-for-selection :simple-selection [sel]
#(= % sel))

;; [:address '*]
;; [:address :country] [:address]
(defmethod filter-fns-for-selection :star-selection [sel]
#(path-matches-selection? % sel))


(defmethod filter-fns-for-selection :question-selection [_sel]
(constantly false))


(defn- required-schema-paths [cleaned-path-to-schema-path-mapping selection-paths]
(let [remove-fns (map remove-fns-for-selection selection-paths)
filter-fns (map filter-fns-for-selection selection-paths)]
(sequence
(comp (remove (apply some-fn remove-fns))
(filter (apply some-fn filter-fns))
(map cleaned-path-to-schema-path-mapping)) (keys cleaned-path-to-schema-path-mapping))))

(defn selectable-paths
"Examples:
(selectable-paths
[:maybe
[:map
[:addresses [:vector [:map
[:street string?]]]]]])
;;=> #{[:addresses] [:addresses :street]}"
[schema]
(->> schema
mu/subschemas
(map (comp clean-path :path))
(filter seq)
set))

(defn- invalid-paths [cleaned-schema-paths selection-paths]
(remove #(some (fn [cp] (path-matches-selection? cp %))
cleaned-schema-paths) selection-paths))


(defn select
Expand Down Expand Up @@ -210,8 +102,10 @@
(select Person [:foo]) ;; Assert exception about non existing path, showing all possible paths.
```
"
([schema] (select schema [] nil))
([schema selection] (select schema selection nil))
([schema]
(select schema [] nil))
([schema selection]
(select schema selection nil))
([schema selection
{:as _options
:keys [verify-selection prune-optionals]
Expand All @@ -220,97 +114,81 @@
prune-optionals false}}]
(letfn [(in? [coll elm]
(some #(= % elm) coll))]
(let [prune-optionals (or (true? prune-optionals) (-> selection meta :only))
schema (m/schema schema)
all-optional? (= [] selection)
selection-paths (parse-selection selection)
verify-selection? (and (not (in? #{nil false :skip} verify-selection))
(not all-optional?))
cleaned-path-to-schema-path-mapping (as-> (requirable-paths schema) $ ;; {[:street '?] [0]}
(zipmap (map clean-path $) $))
unknown-selections (when verify-selection?
(invalid-paths (keys cleaned-path-to-schema-path-mapping)
selection-paths))
required-spaths (when-not all-optional?
(required-schema-paths
cleaned-path-to-schema-path-mapping
selection-paths))
required-paths-mapper (schema-paths->mapper required-spaths)]
(assert (empty? unknown-selections)
(str "Selection contains unknown paths: " (prn-str unknown-selections)
"\nAvailable: " (prn-str (sort (keys cleaned-path-to-schema-path-mapping)))))
(cond-> schema
:always (deep-mark-paths required-paths-mapper
{:all-optional? all-optional?})
prune-optionals deep-prune-optionals)))))

(let [all-optional? (empty? selection)
verify-selection? (and (not (in? #{nil false :skip} verify-selection))
(not all-optional?))
prune-optionals (or (true? prune-optionals)
(-> selection meta :only))
selection-paths (parse-selection selection)
sel-map (paths->tree selection-paths)
!available-paths (atom #{})
!seen (atom #{})
record-seen! (fn [schema path to-require]
(when verify-selection?
(let [available-keys (map first (m/entries schema))
valid-keys (into ['? '*] available-keys)
seen-keys (filter to-require valid-keys)]
(swap! !available-paths into
(map (partial conj path) available-keys))
(swap! !seen into
(map (partial conj path) seen-keys)))))
!prune-exclusions (atom #{})
record-prune-exclusions! (fn [path]
(when prune-optionals
(let [self&parent-paths (take (inc (count path)) (iterate pop path))]
(swap! !prune-exclusions into self&parent-paths))))
map-schema? #(= :map (m/type %))
walked
(m/walk schema
(schema-path-walker
(comp
(fn prune [[schema path]]
(if-not (and prune-optionals (map-schema? schema))
schema
(let [prunable? (every-pred (comp :optional second)
(comp not @!prune-exclusions #(conj path %) first))
children (remove prunable? (m/children schema))]
(m/into-schema (m/type schema) (m/-properties schema) children (m/-options schema)))))
(fn require [[schema path :as args]]
(if (or all-optional? (not (map-schema? schema)))
args
(let [cleaned-path (clean-path path)
to-require (sel-map cleaned-path)]
(if-not (seq to-require)
args
(let [star? (some #{'*} to-require)]
(record-seen! schema cleaned-path to-require)
(record-prune-exclusions! path)
(update args 0
#(if star?
(mu/required-keys %)
(mu/required-keys % to-require))))))))
(fn optionalize [[schema :as args]]
(if-not (map-schema? schema)
args
(update args 0 mu/optional-keys)))
(fn init [& args]
(vec args))))
{::m/walk-schema-refs true ::m/walk-refs true})]
(when verify-selection?
(let [invalid-selection-paths (remove @!seen selection-paths)]
(assert (empty? invalid-selection-paths)
(str "Selection contains unknown paths: " (prn-str invalid-selection-paths)
"\nAvailable: \n" (with-out-str (pprint (sort (selectable-paths schema))))))))

walked))))

(comment

(parse-selection [{:address [:street]} {:address [{:country [:iso]}]}])

(requirable-paths [:schema {:registry {"Other" [:map
[:other boolean?]]}}
[:map
[:this boolean?]
[:that "Other"]]])
(require '[criterium.core :as cc]
'[malli.generator :as mg])

(def Person
[:map
[:name string?]
[:age [:int {:min 0 :max 10}]]
[:age int?]
[:friends [:vector [:map [:name string?]]]]
[:address [:map
[:street string?]
[:number int?]
[:country [:map
[:iso string?]
[:name string?]]]]]])

(cc/quick-bench (select Person [:address {:address ['*]}]))

(paths->tree (parse-selection [{:address ['*]}])) [:address '*]

(m/validate (select Person ['*]) {:name "Gert" :age 1 :friends [] :address {}})

(m/validate (select Person ['* #_{:address [:country {:country ['*]}]}])
{:name "Gert" :age 1 :friends [] :address {}})

(parse-selection [:foo {:bar [] :baz []}])

(requirable-paths [:map-of string? [:vector Person]])
(parse-selection [:name :age {:address [:street]}])
(m/validate (select Person [:address2]) {:address {:street ""}})

(m/validate Person {:name "" :age 1 :address nil})

(mg/generate Person)
(def s1 [:name])
(def s2 [{:address [:street]} :age])
(def s3 [:name {:address ['*]} :age])
(def s4 [:address {:address []}])
(def s5 [{:address [:street {:country [:name '*]}]} :name])
(def s6 [{:address [:street {:country [:name '* :iso]} :number '*]} :name :age '*])

(def Course [:map
[:hash [:string {:min 6 :max 6}]]
[:title string?]
[:subtitle string?]
[:audio [:map
[:length pos-int?]]]
[:image [:map
[:thumbnails [:vector [:map [:thumb-x-1 string?]]]]]]])

(m/walk Course (m/schema-walker (fn [s])))
(m/form (select
Course [{:audio [:length]}]))

(m/entries Course)
(m/form (select Person [:name]))

(require '[clj-async-profiler.core :as prof])
(prof/profile (dotimes [i 10000] (select Person s3)))

(prof/serve-files 8081))
[:addresses [:vector [:map
[:street string?]
[:country string?]]]]])
(require '[criterium.core :as cc])

(m/form (select [:maybe Person] ^:only [{:name ['*]} {:friends [:name]}]))

#_:end)

0 comments on commit bb8fbe6

Please sign in to comment.