-
Notifications
You must be signed in to change notification settings - Fork 204
/
util.cljc
422 lines (374 loc) · 15.7 KB
/
util.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
(ns malli.util
(:refer-clojure :exclude [merge select-keys find get get-in dissoc assoc update assoc-in update-in keys])
(:require [clojure.core :as c]
[malli.core :as m]))
(declare path->in)
(defn ^:no-doc equals
([?schema1 ?schema2]
(equals ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(= (m/form ?schema1 options) (m/form ?schema2 options))))
(defn -simplify-map-entry [[k ?p s]]
(cond
(not s) [k ?p]
(and ?p (false? (:optional ?p)) (= 1 (count ?p))) [k s]
(not (seq ?p)) [k s]
(false? (:optional ?p)) [k (c/dissoc ?p :optional) s]
:else [k ?p s]))
(defn -required-map-entry? [[_ ?p]]
(not (and (map? ?p) (true? (:optional ?p)))))
(defn- -entry [[k ?p1 s1 :as e1] [_ ?p2 s2 :as e2] merge-required merge options]
(let [required (merge-required (-required-map-entry? e1) (-required-map-entry? e2))
p (c/merge ?p1 ?p2)]
(-simplify-map-entry [k (c/assoc p :optional (not required)) (merge s1 s2 options)])))
(defn- -ok-to-close-or-open? [schema options]
(and (= :map (m/type schema options)) (-> schema m/properties :closed false? not)))
;;
;; public api
;;
(defn find-first
"Prewalks the Schema recursively with a 3-arity fn [schema path options], returns with
and as soon as the function returns non-null value."
([?schema f]
(find-first ?schema f nil))
([?schema f options]
(let [result (atom nil)]
(m/-walk
(m/schema ?schema options)
(reify m/Walker
(-accept [_ s path options] (not (or @result (reset! result (f s path options)))))
(-inner [this s path options] (when-not @result (m/-walk s this path options)))
(-outer [_ _ _ _ _]))
[] options)
@result)))
(defn merge
"Merges two schemas into one with the following rules:
* if either schemas is `nil`, the other one is used, regardless of value
* with two :map schemas, both keys and values are merged
* for :and schemas, the first child is used in merge, rest kept as-is
* with two :map entries, `:merge-entries` fn is used (default last one wins)
* with any other schemas, `:merge-default` fn is used (default last one wins)
| key | description
| ------------------|-------------
| `:merge-default` | `schema1 schema2 options -> schema` fn to merge unknown entries
| `:merge-required` | `boolean boolean -> boolean` fn to resolve how required keys are merged"
([?schema1 ?schema2]
(merge ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(let [s1 (when ?schema1 (m/deref-all (m/schema ?schema1 options)))
s2 (when ?schema2 (m/deref-all (m/schema ?schema2 options)))
t1 (when s1 (m/type s1))
t2 (when s2 (m/type s2))
{:keys [merge-default merge-required]
:or {merge-default (fn [_ s2 _] s2)
merge-required (fn [_ r2] r2)}} options
bear (fn [p1 p2] (if (and p1 p2) (c/merge p1 p2) (or p1 p2)))
tear (fn [t s] (if (= :map t) [nil s] (concat [(m/properties s)] (m/children s))))
join (fn [[p1 c1 & cs1] [p2 c2 & cs2]]
(m/into-schema :and (bear p1 p2) (concat [(merge c1 c2 options)] cs1 cs2) options))]
(cond
(nil? s1) s2
(nil? s2) s1
(not (and (-> t1 #{:map :and}) (-> t2 #{:map :and}))) (merge-default s1 s2 options)
(not (and (-> t1 (= :map)) (-> t2 (= :map)))) (join (tear t1 s1) (tear t2 s2))
:else (let [p (bear (m/-properties s1) (m/-properties s2))
ks (atom #{})
children (reduce (fn [form [k2 :as e2]]
(if (@ks k2)
(reduce (fn [acc' [k1 :as e1]]
(conj acc' (if (= k1 k2)
(-entry e1 e2 merge-required merge options)
e1))) [] form)
(do (swap! ks conj k2) (conj form e2))))
[] (into (m/-children s1) (m/-children s2)))]
(m/into-schema :map p children options))))))
(defn union
"Union of two schemas. See [[merge]] for more details."
([?schema1 ?schema2]
(union ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(let [merge-default (fn [s1 s2 options] (if (equals s1 s2) s1 (m/schema [:or s1 s2] options)))
merge-required (fn [r1 r2] (and r1 r2))]
(merge ?schema1 ?schema2 (-> options
(c/update :merge-default (fnil identity merge-default))
(c/update :merge-required (fnil identity merge-required)))))))
(defn update-properties
"Returns a Schema instance with updated properties."
[?schema f & args]
(let [schema (m/schema ?schema)]
(m/-set-properties schema (not-empty (apply f (m/-properties schema) args)))))
(defn closed-schema
"Maps are implicitly open by default. They can be explicitly closed or
open by specifying the `{:closed (true|false)}` property.
This function converts implicitly open maps to explicitly closed
maps, recursively. Explicitly open maps are left untouched.
See [[open-schema]]"
([?schema]
(closed-schema ?schema nil))
([?schema options]
(m/walk
?schema
(m/schema-walker
(fn [schema]
(if (-ok-to-close-or-open? schema options)
(update-properties schema c/assoc :closed true)
schema)))
options)))
(defn open-schema
"Maps are implicitly open by default. They can be explicitly closed or
open by specifying the `{:closed (true|false)}` property.
This function converts explicitly closed maps to implicitly open
maps, recursively. Explicitly open maps are left untouched.
See [[closed-schema]]"
([?schema]
(open-schema ?schema nil))
([?schema options]
(m/walk
?schema
(m/schema-walker
(fn [schema]
(if (-ok-to-close-or-open? schema options)
(update-properties schema c/dissoc :closed)
schema)))
options)))
(defn subschemas
"Returns all subschemas for unique paths as a vector of maps with :schema, :path and :in keys.
Walks over :schema references and top-level :refs. See [[malli.core/-walk]] for all options."
([?schema]
(subschemas ?schema nil))
([?schema options]
(let [schema (m/schema ?schema options)
options (let [ref (and (= :ref (m/type schema)) (m/-ref schema))]
(-> options
(clojure.core/update ::m/walk-schema-refs (fnil identity true))
(clojure.core/update ::m/walk-refs (fn [f] #(or (= ref %) ((m/-boolean-fn f) %))))))
state (atom [])]
(find-first schema (fn [s p _] (swap! state conj {:path p, :in (path->in schema p), :schema s}) nil) options)
@state)))
(defn distinct-by
"Returns a sequence of distinct (f x) values)"
[f coll]
(let [seen (atom #{})]
(filter (fn [x] (let [v (f x)] (when-not (@seen v) (swap! seen conj v)))) coll)))
(defn path->in
"Returns a value path for a given Schema and schema path"
[schema path]
(loop [i 0, s schema, acc []]
(or (and (>= i (count path)) acc)
(recur (inc i) (m/-get s (path i) nil) (cond-> acc (m/-keep s) (conj (path i)))))))
(defn in->paths
"Returns a vector of schema paths for a given Schema and value path"
[schema in]
(let [state (atom [])
in-equals (fn [[x & xs] [y & ys]] (cond (and x (= x y)) (recur xs ys), (= x y) true, (= ::m/in x) (recur xs ys)))
parent-exists (fn [v1 v2] (let [i (min (count v1) (count v2))] (= (subvec v1 0 i) (subvec v2 0 i))))]
(find-first
schema
(fn [_ path _]
(when (and (in-equals (path->in schema path) in) (not (some #(parent-exists path %) @state)))
(swap! state conj path) nil)))
@state))
(defn data-explainer
"Like `m/explainer` but output is pure clojure data. Schema objects have been replaced with their m/form.
Useful when you need to serialise errrors."
([?schema]
(data-explainer ?schema nil))
([?schema options]
(let [explainer' (m/explainer ?schema options)]
(fn data-explainer
([value]
(data-explainer value [] []))
([value in acc]
(some-> (explainer' value in acc)
(c/update :schema m/form)
(c/update :errors (partial mapv #(c/update % :schema m/form)))))))))
(defn explain-data
"Explains a value against a given schema. Like `m/explain` but output is pure clojure data.
Schema objects have been replaced with their `m/form`. Useful when you need to serialise errrors.
Creates the `mu/data-explainer` for every call. When performance matters, (re-)use `mu/data-explainer` instead."
([?schema value]
(explain-data ?schema value nil))
([?schema value options]
((data-explainer ?schema options) value [] [])))
;;
;; EntrySchemas
;;
(defn transform-entries
"Transforms entries with f."
([?schema f]
(transform-entries ?schema f nil))
([?schema f options]
(let [schema (m/deref-all (m/schema ?schema options))]
(m/into-schema (m/-parent schema) (m/-properties schema) (f (m/-children schema)) (or (m/options schema) options)))))
(defn optional-keys
"Makes map keys optional."
([?schema]
(optional-keys ?schema nil nil))
([?schema ?keys]
(let [[keys options] (if (map? ?keys) [nil ?keys] [?keys nil])]
(optional-keys ?schema keys options)))
([?schema keys options]
(let [accept (if keys (set keys) (constantly true))
mapper (fn [[k :as e]] (if (accept k) (c/update e 1 c/assoc :optional true) e))]
(transform-entries ?schema #(map mapper %) options))))
(defn required-keys
"Makes map keys required."
([?schema]
(required-keys ?schema nil nil))
([?schema ?keys]
(let [[keys options] (if (map? ?keys) [nil ?keys] [?keys nil])]
(required-keys ?schema keys options)))
([?schema keys options]
(let [accept (if keys (set keys) (constantly true))
required (fn [p] (let [p' (c/dissoc p :optional)] (when (seq p') p')))
mapper (fn [[k :as e]] (if (accept k) (c/update e 1 required) e))]
(transform-entries ?schema #(map mapper %) options))))
(defn select-keys
"Like [[clojure.core/select-keys]], but for EntrySchemas."
([?schema keys]
(select-keys ?schema keys nil))
([?schema keys options]
(let [key-set (set keys)]
(transform-entries ?schema #(filter (fn [[k]] (key-set k)) %) options))))
(defn rename-keys
"Like [[clojure.set/rename-keys]], but for EntrySchemas. Collisions are resolved in favor of the renamed key, like `assoc`-ing."
([?schema kmap]
(rename-keys ?schema kmap nil))
([?schema kmap options]
(transform-entries
?schema
(fn [entries]
(let [source-keys (set (c/keys kmap))
target-keys (set (vals kmap))
remove-conflicts (fn [[k]] (or (source-keys k) (not (target-keys k))))
alter-keys (fn [[k m v]] [(c/get kmap k k) m v])]
(->> entries (filter remove-conflicts) (map alter-keys))))
options)))
(defn dissoc
"Like [[clojure.core/dissoc]], but for EntrySchemas."
([?schema key]
(dissoc ?schema key nil))
([?schema key options]
(transform-entries ?schema #(remove (fn [[k]] (= key k)) %) options)))
(defn find
"Like [[clojure.core/find]], but for EntrySchemas."
([?schema k]
(find ?schema k nil))
([?schema k options]
(let [schema (m/schema (or ?schema :map) options)]
(when schema (m/-get schema [::m/find k] nil)))))
(defn keys
"Like [[clojure.core/keys]], but for EntrySchemas."
[?schema]
(when-let [ents (m/entries ?schema)]
(for [[k _] ents]
k)))
;;
;; LensSchemas
;;
(defn get
"Like [[clojure.core/get]], but for LensSchemas."
([?schema k]
(get ?schema k nil nil))
([?schema k default]
(get ?schema k default nil))
([?schema k default options]
(let [schema (m/schema (or ?schema :map) options)]
(when schema (m/-get schema k default)))))
(defn assoc
"Like [[clojure.core/assoc]], but for LensSchemas."
([?schema key value]
(assoc ?schema key value nil))
([?schema key value options]
(m/-set (m/schema ?schema options) key value)))
(defn update
"Like [[clojure.core/update]], but for LensSchema instances."
[schema key f & args]
(m/-set (m/schema schema) key (apply f (get schema key) args)))
(defn get-in
"Like [[clojure.core/get-in]], but for LensSchemas."
([?schema ks]
(get-in ?schema ks nil nil))
([?schema ks default]
(get-in ?schema ks default nil))
([?schema [k & ks] default options]
(let [schema (m/schema (or ?schema :map) options)]
(if-not k
schema
(let [sentinel #?(:clj (Object.), :cljs (js-obj))
schema (get schema k sentinel)]
(cond
(identical? schema sentinel) default
ks (get-in schema ks default)
:else schema))))))
(defn assoc-in
"Like [[clojure.core/assoc-in]], but for LensSchemas."
([?schema ks value]
(assoc-in ?schema ks value nil))
([?schema [k & ks] value options]
(let [schema (m/schema ?schema options)]
(assoc schema k (if ks (assoc-in (get schema k (m/schema :map (m/options schema))) ks value) value)))))
(defn update-in
"Like [[clojure.core/update-in]], but for LensSchemas."
[schema ks f & args]
(letfn [(up [s [k & ks] f args]
(assoc s k (if ks (up (get s k (m/schema :map (m/options schema))) ks f args)
(apply f (get s k) args))))]
(up schema ks f args)))
;;
;; Schemas
;;
(defn -reducing [f]
(fn [_ [first & rest :as children] options]
(let [children (mapv #(m/schema % options) children)]
[children (mapv m/form children) (reduce #(f %1 %2 options) first rest)])))
(defn -applying [f]
(fn [_ children options]
[(clojure.core/update children 0 #(m/schema % options))
(clojure.core/update children 0 #(m/form % options))
(apply f (conj children options))]))
(defn -util-schema [{:keys [type min max childs type-properties fn]}]
^{:type ::m/into-schema}
(reify m/IntoSchema
(-type [_] type)
(-type-properties [_] type-properties)
(-properties-schema [_ _])
(-children-schema [_ _])
(-into-schema [parent properties children options]
(m/-check-children! type properties children min max)
(let [[children forms schema] (fn properties (vec children) options)
form (delay (m/-create-form type properties forms options))
cache (m/-create-cache options)]
^{:type ::m/schema}
(reify
m/Schema
(-validator [_] (m/-validator schema))
(-explainer [_ path] (m/-explainer schema path))
(-parser [_] (m/-parser schema))
(-unparser [_] (m/-unparser schema))
(-transformer [this transformer method options]
(m/-parent-children-transformer this [schema] transformer method options))
(-walk [this walker path options]
(let [children (if childs (subvec children 0 childs) children)]
(when (m/-accept walker this path options)
(m/-outer walker this path (m/-inner-indexed walker path children options) options))))
(-properties [_] properties)
(-options [_] options)
(-children [_] children)
(-parent [_] parent)
(-form [_] @form)
m/Cached
(-cache [_] cache)
m/LensSchema
(-keep [_])
(-get [_ key default] (clojure.core/get children key default))
(-set [_ key value] (m/into-schema type properties (clojure.core/assoc children key value)))
m/RefSchema
(-ref [_])
(-deref [_] schema))))))
(defn -merge [] (-util-schema {:type :merge, :fn (-reducing merge)}))
(defn -union [] (-util-schema {:type :union, :fn (-reducing union)}))
(defn -select-keys [] (-util-schema {:type :select-keys, :childs 1, :min 2, :max 2, :fn (-applying select-keys)}))
(defn schemas [] {:merge (-merge)
:union (-union)
:select-keys (-select-keys)})