Skip to content

Commit f664244

Browse files
ikitommiikitommi
authored
Merge pull request #1144 from frenchy64/unreachable-gen-idiom
refactor generator ns with -never-gen helpers
2 parents 0b69456 + affa1f3 commit f664244

File tree

2 files changed

+96
-186
lines changed

2 files changed

+96
-186
lines changed

‎src/malli/generator.cljc

+90-179
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
;; See also `malli.generator-ast` for viewing generators as data
22
(ns malli.generator
3-
(:require [clojure.spec.gen.alpha :as ga]
3+
(:require [clojure.set :as set]
4+
[clojure.spec.gen.alpha :as ga]
45
[clojure.string :as str]
56
[clojure.test.check :as check]
67
[clojure.test.check.generators :as gen]
@@ -13,7 +14,7 @@
1314
[malli.impl.util :refer [-last -merge]]
1415
#?(:clj [borkdude.dynaload :as dynaload])))
1516

16-
(declare generator generate -create)
17+
(declare generator generate -create gen-one-of gen-double)
1718

1819
(defprotocol Generator
1920
(-generator [this options] "returns generator for schema"))
@@ -51,11 +52,14 @@
5152

5253
(def nil-gen (gen/return nil))
5354

55+
(defn- -child [schema options] (first (m/children schema options)))
56+
(defn- -child-gen [schema options] (generator (-child schema options) options))
57+
5458
(defn -never-gen
5559
"Return a generator of no values that is compatible with -unreachable-gen?."
5660
[{::keys [original-generator-schema] :as _options}]
5761
(with-meta (gen/sized (fn [_]
58-
(m/-fail! ::infinitely-expanding-schema
62+
(m/-fail! ::unsatisfiable-schema
5963
(cond-> {}
6064
original-generator-schema (assoc :schema original-generator-schema)))))
6165
{::never-gen true
@@ -66,17 +70,10 @@
6670
[g] (-> (meta g) ::never-gen boolean))
6771

6872
(defn -not-unreachable [g] (when-not (-unreachable-gen? g) g))
73+
(defn -unreachable [g] (when (-unreachable-gen? g) g))
6974

7075
(defn- -random [seed] (if seed (random/make-random seed) (random/make-random)))
7176

72-
(defn ^:deprecated -recur [_schema options]
73-
(println (str `-recur " is deprecated, please update your generators. See instructions in malli.generator."))
74-
[true options])
75-
76-
(defn ^:deprecated -maybe-recur [_schema options]
77-
(println (str `-maybe-recur " is deprecated, please update your generators. See instructions in malli.generator."))
78-
options)
79-
8077
(defn -min-max [schema options]
8178
(let [{:keys [min max] gen-min :gen/min gen-max :gen/max} (m/properties schema options)]
8279
(when (and min gen-min (< gen-min min))
@@ -86,68 +83,64 @@
8683
{:min (or gen-min min)
8784
:max (or gen-max max)}))
8885

89-
(defn- -double-gen [options] (gen/double* (merge {:infinite? false, :NaN? false} options)))
90-
91-
(defn- gen-vector-min [gen min options]
92-
(cond-> (gen/sized #(gen/vector gen min (+ min %)))
93-
(::generator-ast options) (vary-meta assoc ::generator-ast
94-
{:op :vector-min
95-
:generator gen
96-
:min min})))
86+
(defn- inf-nan [schema options]
87+
(let [{:gen/keys [infinite? NaN?]} (m/properties schema)]
88+
{:infinite? infinite? :NaN? NaN?}))
89+
90+
(defn- -double-gen [schema options] (gen-double (into (inf-nan schema options) (-min-max schema options))))
91+
92+
(defn- gen-fmap [f gen] (or (-unreachable gen) (gen/fmap f gen)))
93+
(defn- gen-fcat [gen] (gen-fmap #(apply concat %) gen))
94+
(defn- gen-tuple [gens] (or (some -unreachable gens) (apply gen/tuple gens)))
95+
(defn- gen-maybe [g] (if (-unreachable-gen? g) nil-gen (gen/one-of [nil-gen g])))
96+
(def ^:private double-default {:infinite? false, :NaN? false})
97+
(defn- gen-double [opts] (gen/double* (-> (into double-default opts) (update :min #(some-> % double)) (update :max #(some-> % double)))))
98+
99+
(defn- gen-vector [{:keys [min max]} g]
100+
(cond
101+
(-unreachable-gen? g) (if (zero? (or min 0)) (gen/return []) g)
102+
(and min (= min max)) (gen/vector g min)
103+
(and min max) (gen/vector g min max)
104+
min (vary-meta (gen/sized #(gen/vector g min (+ min %))) assoc ::generator-ast {:op :vector-min :generator g :min min})
105+
max (gen/vector g 0 max)
106+
:else (gen/vector g)))
107+
108+
(defn- gen-vector-distinct-by [schema {:keys [min] :as m} f g]
109+
(if (-unreachable-gen? g)
110+
(if (= 0 (or min 0)) (gen/return []) g)
111+
(gen/vector-distinct-by f g (-> (assoc (if (and min (= min max))
112+
{:num-elements min}
113+
(set/rename-keys m {:min :min-elements :max :max-elements}))
114+
:ex-fn #(m/-exception ::distinct-generator-failure (assoc % :schema schema)))))))
97115

98116
(defn- -string-gen [schema options]
99-
(let [{:keys [min max]} (-min-max schema options)]
100-
(cond
101-
(and min (= min max)) (gen/fmap str/join (gen/vector gen/char-alphanumeric min))
102-
(and min max) (gen/fmap str/join (gen/vector gen/char-alphanumeric min max))
103-
min (gen/fmap str/join (gen-vector-min gen/char-alphanumeric min options))
104-
max (gen/fmap str/join (gen/vector gen/char-alphanumeric 0 max))
105-
:else gen/string-alphanumeric)))
106-
107-
(defn- -coll-gen [schema f options]
108-
(let [{:keys [min max]} (-min-max schema options)
109-
child (-> schema m/children first)
110-
gen (generator child options)]
111-
(if (-unreachable-gen? gen)
112-
(if (= 0 (or min 0))
113-
(gen/fmap f (gen/return []))
114-
(-never-gen options))
115-
(gen/fmap f (cond
116-
(and min (= min max)) (gen/vector gen min)
117-
(and min max) (gen/vector gen min max)
118-
min (gen-vector-min gen min options)
119-
max (gen/vector gen 0 max)
120-
:else (gen/vector gen))))))
117+
(gen-fmap str/join (gen-vector (-min-max schema options) gen/char-alphanumeric)))
118+
119+
(defn- -coll-gen
120+
([schema options] (-coll-gen schema identity options))
121+
([schema f options] (gen-fmap f (gen-vector (-min-max schema options) (-child-gen schema options)))))
122+
123+
(defn- gen-vector-distinct [schema m g] (gen-vector-distinct-by schema m identity g))
121124

122125
(defn- -coll-distinct-gen [schema f options]
123-
(let [{:keys [min max]} (-min-max schema options)
124-
child (-> schema m/children first)
125-
gen (generator child options)]
126-
(if (-unreachable-gen? gen)
127-
(if (= 0 (or min 0))
128-
(gen/return (f []))
129-
(-never-gen options))
130-
(gen/fmap f (gen/vector-distinct gen {:min-elements min, :max-elements max, :max-tries 100
131-
:ex-fn #(m/-exception ::distinct-generator-failure
132-
(assoc % :schema schema))})))))
126+
(gen-fmap f (gen-vector-distinct schema (-min-max schema options) (-child-gen schema options))))
127+
128+
(defn- ->such-that-opts [schema] {:max-tries 100 :ex-fn #(m/-exception ::such-that-failure (assoc % :schema schema))})
129+
(defn- gen-such-that [schema pred gen] (or (-unreachable gen) (gen/such-that pred gen (->such-that-opts schema))))
133130

134131
(defn -and-gen [schema options]
135-
(if-some [gen (-not-unreachable (-> schema (m/children options) first (generator options)))]
136-
(gen/such-that (m/validator schema options) gen
137-
{:max-tries 100
138-
:ex-fn #(m/-exception ::and-generator-failure
139-
(assoc % :schema schema))})
140-
(-never-gen options)))
132+
(gen-such-that schema (m/validator schema options) (-child-gen schema options)))
141133

142-
(defn- gen-one-of [gs]
143-
(if (= 1 (count gs))
144-
(first gs)
145-
(gen/one-of gs)))
134+
(defn- gen-one-of [options gs]
135+
(if-some [gs (not-empty (into [] (keep -not-unreachable) gs))]
136+
(if (= 1 (count gs)) (nth gs 0) (gen/one-of gs))
137+
(-never-gen options)))
146138

147139
(defn- -seqable-gen [schema options]
148140
(let [{:keys [min]} (-min-max schema options)
149-
el (-> schema m/children first)]
141+
el (-child schema options)]
150142
(gen-one-of
143+
options
151144
(-> []
152145
(cond->
153146
(or (nil? min) (zero? min))
@@ -162,11 +155,7 @@
162155
(generator [:map-of (or (m/properties schema) {}) k v] options))))))))
163156

164157
(defn -or-gen [schema options]
165-
(if-some [gs (not-empty
166-
(into [] (keep #(-not-unreachable (generator % options)))
167-
(m/children schema options)))]
168-
(gen-one-of gs)
169-
(-never-gen options)))
158+
(gen-one-of options (map #(generator % options) (m/children schema options))))
170159

171160
(defn- -merge-keyword-dispatch-map-into-entries [schema]
172161
(let [dispatch (-> schema m/properties :dispatch)]
@@ -180,11 +169,7 @@
180169
(m/options schema)))))
181170

182171
(defn -multi-gen [schema options]
183-
(if-some [gs (->> (m/entries (-merge-keyword-dispatch-map-into-entries schema) options)
184-
(into [] (keep #(-not-unreachable (generator (last %) options))))
185-
(not-empty))]
186-
(gen-one-of gs)
187-
(-never-gen options)))
172+
(gen-one-of options (map #(generator (last %) options) (m/entries (-merge-keyword-dispatch-map-into-entries schema) options))))
188173

189174
(defn- -build-map [kvs]
190175
(persistent!
@@ -195,43 +180,16 @@
195180
:else (assoc! acc k v)))
196181
(transient {}) kvs)))
197182

198-
(defn- -value-gen [k s options]
199-
(let [g (generator s options)]
200-
(cond->> g (-not-unreachable g) (gen/fmap (fn [v] [k v])))))
183+
(defn- -entry-gen [[k s] options]
184+
(cond->> (gen-fmap #(do [k %]) (generator s options)) (-> s m/properties :optional) gen-maybe))
201185

202186
(defn -map-gen [schema options]
203-
(loop [[[k s :as e] & entries] (m/entries schema)
204-
gens []]
205-
(if (nil? e)
206-
(gen/fmap -build-map (apply gen/tuple gens))
207-
(if (-> e -last m/properties :optional)
208-
;; opt
209-
(recur
210-
entries
211-
(conj gens
212-
(if-let [g (-not-unreachable (-value-gen k s options))]
213-
(gen-one-of [nil-gen g])
214-
nil-gen)))
215-
;;; req
216-
(let [g (-value-gen k s options)]
217-
(if (-unreachable-gen? g)
218-
(-never-gen options)
219-
(recur entries (conj gens g))))))))
187+
(->> schema m/entries (map #(-entry-gen % options)) gen-tuple (gen-fmap -build-map)))
220188

221189
(defn -map-of-gen [schema options]
222-
(let [{:keys [min max]} (-min-max schema options)
223-
[k-gen v-gen :as gs] (map #(generator % options) (m/children schema options))]
224-
(if (some -unreachable-gen? gs)
225-
(if (= 0 (or min 0))
226-
(gen/return {})
227-
(-never-gen options))
228-
(let [opts (-> (cond
229-
(and min (= min max)) {:num-elements min}
230-
(and min max) {:min-elements min :max-elements max}
231-
min {:min-elements min}
232-
max {:max-elements max})
233-
(assoc :ex-fn #(m/-exception ::distinct-generator-failure (assoc % :schema schema))))]
234-
(gen/fmap #(into {} %) (gen/vector-distinct-by first (gen/tuple k-gen v-gen) opts))))))
190+
(->> (gen-tuple (map #(generator % options) (m/children schema options)))
191+
(gen-vector-distinct-by schema (-min-max schema options) #(nth % 0))
192+
(gen-fmap #(into {} %))))
235193

236194
#?(:clj
237195
(defn -re-gen [schema options]
@@ -359,67 +317,40 @@
359317
(gen/return (m/-instrument {:schema schema, :gen #(generate % options)} nil options)))
360318

361319
(defn -regex-generator [schema options]
362-
(if (m/-regex-op? schema)
363-
(generator schema options)
364-
(let [g (generator schema options)]
365-
(cond-> g
366-
(-not-unreachable g) gen/tuple))))
320+
(cond-> (generator schema options) (not (m/-regex-op? schema)) (-> vector gen-tuple)))
367321

368-
(defn- entry->schema [e] (if (vector? e) (get e 2) e))
322+
(defn- -re-entry-gen [e options] (-regex-generator (if (vector? e) (get e 2) e) options))
369323

370324
(defn -cat-gen [schema options]
371-
(let [gs (->> (m/children schema options)
372-
(map #(-regex-generator (entry->schema %) options)))]
373-
(if (some -unreachable-gen? gs)
374-
(-never-gen options)
375-
(->> gs
376-
(apply gen/tuple)
377-
(gen/fmap #(apply concat %))))))
325+
(->> (m/children schema options) (map #(-re-entry-gen % options)) gen-tuple gen-fcat))
378326

379327
(defn -alt-gen [schema options]
380-
(let [gs (->> (m/children schema options)
381-
(keep #(-regex-generator (entry->schema %) options)))]
382-
(if (every? -unreachable-gen? gs)
383-
(-never-gen options)
384-
(gen-one-of (into [] (keep -not-unreachable) gs)))))
328+
(->> (m/children schema options) (map #(-re-entry-gen % options)) (gen-one-of options)))
385329

386330
(defn -?-gen [schema options]
387-
(let [child (m/-get schema 0 nil)]
331+
(let [child (-child schema options)]
388332
(if-some [g (-not-unreachable (generator child options))]
389333
(if (m/-regex-op? child)
390334
(gen/one-of [g (gen/return ())])
391335
(gen/vector g 0 1))
392336
(gen/return ()))))
393337

394338
(defn -*-gen [schema options]
395-
(let [child (m/-get schema 0 nil)
396-
mode (::-*-gen-mode options :*)
397-
options (dissoc options ::-*-gen-mode)]
398-
(if-some [g (-not-unreachable (generator child options))]
399-
(cond->> (case mode
400-
:* (gen/vector g)
401-
:+ (gen-vector-min g 1 options))
402-
(m/-regex-op? child)
403-
(gen/fmap #(apply concat %)))
404-
(case mode
405-
:* (gen/return ())
406-
:+ (-never-gen options)))))
339+
(let [child (-child schema options)]
340+
(cond->> (gen-vector (when (= :+ (::-*-gen-mode options)) {:min 1}) (generator child (dissoc options ::-*-gen-mode)))
341+
(m/-regex-op? child) gen-fcat)))
407342

408343
(defn -+-gen [schema options]
409344
(-*-gen schema (assoc options ::-*-gen-mode :+)))
410345

411346
(defn -repeat-gen [schema options]
412-
(let [child (m/-get schema 0 nil)]
413-
(if-some [g (-not-unreachable (-coll-gen schema identity options))]
414-
(cond->> g
415-
(m/-regex-op? child)
416-
(gen/fmap #(apply concat %)))
417-
(gen/return ()))))
347+
(or (some-> (-coll-gen schema options) -not-unreachable (cond-> (m/-regex-op? (-child schema options)) gen-fcat))
348+
(gen/return ())))
418349

419350
(defn -qualified-ident-gen [schema mk-value-with-ns value-with-ns-gen-size pred gen]
420351
(if-let [namespace-unparsed (:namespace (m/properties schema))]
421-
(gen/fmap (fn [k] (mk-value-with-ns (name namespace-unparsed) (name k))) value-with-ns-gen-size)
422-
(gen/such-that pred gen {:ex-fn #(m/-exception ::qualified-ident-gen-failure (assoc % :schema schema))})))
352+
(gen-fmap (fn [k] (mk-value-with-ns (name namespace-unparsed) (name k))) value-with-ns-gen-size)
353+
(gen-such-that schema pred gen)))
423354

424355
(defn -qualified-keyword-gen [schema]
425356
(-qualified-ident-gen schema keyword gen/keyword qualified-keyword? gen/keyword-ns))
@@ -436,57 +367,37 @@
436367

437368
(defmethod -schema-generator ::default [schema options] (ga/gen-for-pred (m/validator schema options)))
438369

439-
(defmethod -schema-generator :> [schema options] (-double-gen {:min (-> schema (m/children options) first inc)}))
440-
(defmethod -schema-generator :>= [schema options] (-double-gen {:min (-> schema (m/children options) first)}))
441-
(defmethod -schema-generator :< [schema options] (-double-gen {:max (-> schema (m/children options) first dec)}))
442-
(defmethod -schema-generator :<= [schema options] (-double-gen {:max (-> schema (m/children options) first)}))
443-
(defmethod -schema-generator := [schema options] (gen/return (first (m/children schema options))))
444-
(defmethod -schema-generator :not= [schema options] (gen/such-that #(not= % (-> schema (m/children options) first)) gen/any-printable
445-
{:max-tries 100
446-
:ex-fn #(m/-exception ::not=-generator-failure (assoc % :schema schema))}))
447-
(defmethod -schema-generator 'pos? [_ _] (gen/one-of [(-double-gen {:min 0.00001}) (gen/fmap inc gen/nat)]))
448-
(defmethod -schema-generator 'neg? [_ _] (gen/one-of [(-double-gen {:max -0.0001}) (gen/fmap (comp dec -) gen/nat)]))
449-
450-
(defmethod -schema-generator :not [schema options] (gen/such-that (m/validator schema options) (ga/gen-for-pred any?)
451-
{:max-tries 100
452-
:ex-fn #(m/-exception ::not-generator-failure (assoc % :schema schema))}))
370+
(defmethod -schema-generator :> [schema options] (gen-double {:min (inc (-child schema options))}))
371+
(defmethod -schema-generator :>= [schema options] (gen-double {:min (-child schema options)}))
372+
(defmethod -schema-generator :< [schema options] (gen-double {:max (dec (-child schema options))}))
373+
(defmethod -schema-generator :<= [schema options] (gen-double {:max (-child schema options)}))
374+
(defmethod -schema-generator := [schema options] (gen/return (-child schema options)))
375+
(defmethod -schema-generator :not= [schema options] (gen-such-that schema #(not= % (-child schema options)) gen/any-printable))
376+
(defmethod -schema-generator 'pos? [_ options] (gen/one-of [(gen-double {:min 0.00001}) (gen-fmap inc gen/nat)]))
377+
(defmethod -schema-generator 'neg? [_ options] (gen/one-of [(gen-double {:max -0.00001}) (gen-fmap (comp dec -) gen/nat)]))
378+
(defmethod -schema-generator :not [schema options] (gen-such-that schema (m/validator schema options) (ga/gen-for-pred any?)))
453379
(defmethod -schema-generator :and [schema options] (-and-gen schema options))
454380
(defmethod -schema-generator :or [schema options] (-or-gen schema options))
455381
(defmethod -schema-generator :orn [schema options] (-or-gen (m/into-schema :or (m/properties schema) (map last (m/children schema)) (m/options schema)) options))
456-
(defmethod -schema-generator ::m/val [schema options] (generator (first (m/children schema)) options))
382+
(defmethod -schema-generator ::m/val [schema options] (-child-gen schema options))
457383
(defmethod -schema-generator :map [schema options] (-map-gen schema options))
458384
(defmethod -schema-generator :map-of [schema options] (-map-of-gen schema options))
459385
(defmethod -schema-generator :multi [schema options] (-multi-gen schema options))
460-
(defmethod -schema-generator :vector [schema options] (-coll-gen schema identity options))
461-
(defmethod -schema-generator :sequential [schema options] (-coll-gen schema identity options))
386+
(defmethod -schema-generator :vector [schema options] (-coll-gen schema options))
387+
(defmethod -schema-generator :sequential [schema options] (-coll-gen schema options))
462388
(defmethod -schema-generator :set [schema options] (-coll-distinct-gen schema set options))
463389
(defmethod -schema-generator :enum [schema options] (gen-elements (m/children schema options)))
464390
(defmethod -schema-generator :seqable [schema options] (-seqable-gen schema options))
465391
(defmethod -schema-generator :every [schema options] (-seqable-gen schema options)) ;;infinite seqs?
466-
467-
(defmethod -schema-generator :maybe [schema options]
468-
(let [g (-> schema (m/children options) first (generator options) -not-unreachable)]
469-
(gen-one-of (cond-> [nil-gen]
470-
g (conj g)))))
471-
472-
(defmethod -schema-generator :tuple [schema options]
473-
(let [gs (map #(generator % options) (m/children schema options))]
474-
(if (not-any? -unreachable-gen? gs)
475-
(apply gen/tuple gs)
476-
(-never-gen options))))
392+
(defmethod -schema-generator :maybe [schema options] (gen-maybe (-child-gen schema options)))
393+
(defmethod -schema-generator :tuple [schema options] (gen-tuple (map #(generator % options) (m/children schema options))))
477394
#?(:clj (defmethod -schema-generator :re [schema options] (-re-gen schema options)))
478395
(defmethod -schema-generator :any [_ _] (ga/gen-for-pred any?))
479396
(defmethod -schema-generator :some [_ _] gen/any-printable)
480397
(defmethod -schema-generator :nil [_ _] nil-gen)
481398
(defmethod -schema-generator :string [schema options] (-string-gen schema options))
482399
(defmethod -schema-generator :int [schema options] (gen/large-integer* (-min-max schema options)))
483-
(defmethod -schema-generator :double [schema options]
484-
(gen/double* (merge (let [props (m/properties schema options)]
485-
{:infinite? (get props :gen/infinite? false)
486-
:NaN? (get props :gen/NaN? false)})
487-
(-> (-min-max schema options)
488-
(update :min #(some-> % double))
489-
(update :max #(some-> % double))))))
400+
(defmethod -schema-generator :double [schema options] (-double-gen schema options))
490401
(defmethod -schema-generator :float [schema options]
491402
(let [max-float #?(:clj Float/MAX_VALUE :cljs (.-MAX_VALUE js/Number))
492403
min-float (- max-float)

0 commit comments

Comments
 (0)