diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index ce3cfd3e6..f780d1543 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -2,6 +2,7 @@ (ns malli.generator (:require [clojure.spec.gen.alpha :as ga] [clojure.string :as str] + [clojure.set :as set] [clojure.test.check :as check] [clojure.test.check.generators :as gen] [clojure.test.check.properties :as prop] @@ -9,10 +10,11 @@ [clojure.test.check.rose-tree :as rose] [malli.core :as m] [malli.registry :as mr] + [malli.util :as u] [malli.impl.util :refer [-last -merge]] #?(:clj [borkdude.dynaload :as dynaload]))) -(declare generator generate -create) +(declare generator generate -create sampling-eduction) (defprotocol Generator (-generator [this options] "returns generator for schema")) @@ -68,6 +70,34 @@ (defn- -random [seed] (if seed (random/make-random seed) (random/make-random))) +(defn- seeded + "Creates a generator that depends on the seed parameter. + `sized-gen` is a function that takes an integer and returns + a generator. + + Examples: + + ;; generates an :int with the same seed as the outer sample. + (gen/sample (seeded (fn [seed] + (gen/tuple (gen/return seed) + (generator :int {:seed seed}))))) + => ([-9189345824394269271 0] + [2069340105756572361 -1] + [-382523443817476848 -1] + [-727106358269903677 0] + [3041036363633372983 -1] + [-3816606844531533988 1] + [-5643022030666591503 -1] + [7456223948749621027 -1] + [5327329620473603684 34] + [8284970028005224634 12])" + [seeded-gen] + (#'gen/make-gen ;;FIXME bb + (fn [^clojure.test.check.random.JavaUtilSplittableRandom rnd size] + (let [seeded-gen (seeded-gen (or (.-state rnd) + (throw (m/-exception ::failed-to-recover-seed))))] + (gen/call-gen seeded-gen rnd size))))) + (defn ^:deprecated -recur [_schema options] (println (str `-recur " is deprecated, please update your generators. See instructions in malli.generator.")) [true options]) @@ -322,12 +352,104 @@ (realized? scalar-ref-gen) (gen/recursive-gen #(generator dschema (assoc-in options [::rec-gen ref-id] %)))))))) +;; # Function generators +;; +;; A naive implementation of a function generator might be to mg/generate the output schema every time +;; the function is called and return the result. Without a seed, this is not reproducible and is not pure. +;; With a seed, mg/generate will return the same value every time---a very boring pure function. +;; +;; + +(defn- non-zero [n] + (cond-> n (zero? n) unchecked-inc)) + +(defn- summarize-string [x] + (non-zero (reduce #(unchecked-add %1 (int %2)) 0 x))) + +(defn- generate-pure-=> [?schema {:keys [seed size] :as options}] + (assert seed) + (assert size) + (let [schema (m/schema ?schema) + options (m/options schema) + _ (assert (= :=> (m/type schema))) + [input output guard] (m/children schema) + _ (assert (not guard) "NYI guards")] + (fn [& args] + (let [n (letfn [(summarize-ident [x] + (non-zero (unchecked-add (unknown (namespace x)) + (unknown (name x))))) + (unknown [x] + (cond + (boolean? x) (if x 1 0) + (int? x) x + (string? x) (summarize-string x) + (ident? x) (summarize-ident x) + (coll? x) (reduce #(unchecked-add %1 (unknown %2)) 0 + (eduction + (if (and (seq? x) (not (counted? x))) + (take 32) + identity) + x)) + (fn? x) 64 + (ifn? x) -64 + (instance? java.math.BigInteger x) (unknown (.toPlainString ^java.math.BigInteger x)) + (instance? clojure.lang.BigInt x) (unknown (str x)) + (instance? java.math.BigDecimal x) (unknown (.toPlainString ^java.math.BigDecimal x)) + (instance? Float x) (Float/floatToIntBits x) + (instance? Double x) (Double/doubleToLongBits x) + (instance? java.util.concurrent.atomic.AtomicInteger x) (.longValue ^java.util.concurrent.atomic.AtomicInteger x) + (instance? java.util.concurrent.atomic.AtomicLong x) (.longValue ^java.util.concurrent.atomic.AtomicLong x) + (instance? clojure.lang.IAtom2 x) (unchecked-add (unknown @x) 1024) + :else 0)) + (known [schema x] + (unchecked-multiply + (let [] + (case (m/type schema) + :cat (let [cs (m/children schema) + vs (m/parse schema (or x ()) options)] + (if (= vs ::m/invalid) + (throw (m/-exception ::invalid-cat {:schema schema :x x})) + (reduce (fn [n i] + (let [c (nth cs i) + v (nth vs i)] + (unchecked-add n (known c v)))) + 0 (range (count cs))))) + :=> (let [[input output guard] (m/children schema) + _ (assert (not guard) (str `generate-pure-=> " TODO :=> guard")) + args (generate input {:size size :seed seed})] + (known output (apply x args))) + (do (or (m/validate schema x) + (throw (m/-exception ::invalid-cat {:schema schema :x x}))) + (unchecked-add + (unknown (m/type schema)) + (unknown x))))) + (unchecked-inc size)))] + (known input args)) + seed (cond-> n seed (unchecked-add seed))] + (generate output (assoc options :seed seed)))))) + +(defn generate-impure-=> [schema options] + (let [a (atom (sampling-eduction (:output (m/-function-info schema)) options))] + (m/-instrument {:schema schema} (fn [& _] (ffirst (swap-vals! a rest)))))) + (defn -=>-gen [schema options] - (let [output-generator (generator (:output (m/-function-info schema)) options)] - (gen/return (m/-instrument {:schema schema} (fn [& _] (generate output-generator options)))))) + (let [generate-=> (if (:gen/impure (m/properties schema)) generate-impure-=> generate-pure-=>)] + (gen/sized + (fn [size] + (seeded + (fn [seed] + (gen/return + (generate-=> schema (assoc options :seed seed :size size))))))))) (defn -function-gen [schema options] - (gen/return (m/-instrument {:schema schema, :gen #(generate % options)} options))) + (gen/sized + (fn [size] + (seeded + (fn [seed] + (let [options (-> options + (assoc :size size) + (assoc :seed seed))] + (gen/return (m/-instrument {:schema schema, :gen #(generate % options)} nil options)))))))) (defn -regex-generator [schema options] (if (m/-regex-op? schema) @@ -496,7 +618,11 @@ (extend-protocol Generator #?(:clj Object, :cljs default) (-generator [schema options] - (-schema-generator schema (assoc options ::original-generator-schema schema)))) + (if-some [poly (::poly-poc (m/properties schema))] + (let [] + (gen/sized (fn [size] + (rand-nth )))) + (-schema-generator schema (assoc options ::original-generator-schema schema))))) (defn- -create-from-gen [props schema options] @@ -531,7 +657,17 @@ ;; public api ;; +(defn- current-time [] + #?(:clj (System/currentTimeMillis) + :cljs (.valueOf (js/Date.)))) + +(defn init-generator-options [options] + (-> options + (update ::state #(or % (atom {}))))) + (defn generator + ":seed - set seed + :size - set size" ([?schema] (generator ?schema nil)) ([?schema options] @@ -540,14 +676,22 @@ (-create (m/schema ?schema options) options) (m/-cached (m/schema ?schema options) :generator #(-create % options))))) +(defn- gen-root [options gen rnd size] + (rose/root (gen/call-gen gen rnd size))) + (defn generate ([?gen-or-schema] (generate ?gen-or-schema nil)) ([?gen-or-schema {:keys [seed size] :or {size 30} :as options}] (let [gen (if (gen/generator? ?gen-or-schema) ?gen-or-schema (generator ?gen-or-schema options))] - (rose/root (gen/call-gen gen (-random seed) size))))) + (gen-root options gen (-random seed) size)))) (defn sample + "An infinite eduction of generator samples, or length :samples. + + :seed - set seed + :size - set size + :samples - set number of samples, or :size is used" ([?gen-or-schema] (sample ?gen-or-schema nil)) ([?gen-or-schema {:keys [seed size] :or {size 10} :as options}] @@ -557,6 +701,37 @@ (gen/lazy-random-states (-random seed))) (take size))))) +(defn sampling-eduction + "An infinite eduction of generator samples. + + :seed - set seed + :size - set size + + Second argument can be a transducer that is applied at the end of the eduction. + For 2-arity, transducer must be fn?, otherwise is treated as options. + + (sampling-eduction :int (take 15)) + ;=> (-1 -1 1 -1 -2 -11 0 -7 -46 122 -1 0 -1 0 0) + (sequence (take 15) (sampling-eduction :int {:seed 10})) + ;=> (-1 0 -1 3 1 3 -2 -2 5 0 -1 -1 -2 3 -5) + (sampling-eduction :int (take 15) {:seed 10}) + ;=> (-1 0 -1 3 1 3 -2 -2 5 0 -1 -1 -2 3 -5)." + ([?gen-or-schema] + (sampling-eduction ?gen-or-schema identity nil)) + ([?gen-or-schema ?options-or-xform-fn] + (let [xform? (fn? ?options-or-xform-fn)] + (sampling-eduction ?gen-or-schema + (if xform? ?options-or-xform-fn identity) + (when-not xform? ?options-or-xform-fn)))) + ([?gen-or-schema xform {:keys [seed size] :or {size 10} :as options}] + (let [gen (if (gen/generator? ?gen-or-schema) ?gen-or-schema (generator ?gen-or-schema options))] + (eduction + (map-indexed (fn [iter rnd] + (let [size (mod iter size)] + (gen-root options gen rnd size)))) + (or xform identity) + (gen/lazy-random-states (-random seed)))))) + ;; ;; functions ;; @@ -574,6 +749,7 @@ validate (fn [f args] (as-> (apply f args) $ (and (valid-output? $) (valid-guard? [args $]))))] (fn [f] (let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(validate f %)) + ;;TODO propagate seed/size (check/quick-check =>iterations)) smallest (-> shrunk :smallest first)] (when-not (true? result) diff --git a/test/malli/generator_debug.cljc b/test/malli/generator_debug.cljc index 7614442d5..55f17df24 100644 --- a/test/malli/generator_debug.cljc +++ b/test/malli/generator_debug.cljc @@ -46,5 +46,6 @@ (defn not-empty [gen] {:op :not-empty :gen gen}) (defn generator? [& args] (assert nil "no stub for generator?")) (defn call-gen [& args] (assert nil "no stub for call-gen")) +(defn make-gen [& args] (assert nil "no stub for make-gen")) (defn make-size-range-seq [& args] (assert nil "no stub for make-size-range-seq")) (defn lazy-random-states [& args] (assert nil "no stub for lazy-random-states")) diff --git a/test/malli/generator_test.cljc b/test/malli/generator_test.cljc index 7e200711d..33aea70bd 100644 --- a/test/malli/generator_test.cljc +++ b/test/malli/generator_test.cljc @@ -1034,3 +1034,57 @@ #?(:clj Exception, :cljs js/Error) #":malli\.generator/and-generator-failure" (mg/generate [:and pos? neg?])))) + +(deftest deterministic-pure-fn-gen-test + (is (every? #{-106} (repeatedly 10 (partial (mg/generate [:=> [:cat :int] :int] {:seed 0 :size 10}) 2)))) + (is (= '(-11901892 -5288 -85 -1 -1380 479 -28741703 57202930 0 -46414) + (map (mg/generate [:=> [:cat :int] :int] {:seed 1 :size 30}) (range 10)))) + (is (every? #{2483} (repeatedly 10 (partial (mg/generate [:=> [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + identity)))) + (is (every? #{117} (repeatedly 10 (partial (mg/generate [:=> [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + str)))) + (is (every? #{-7458} (repeatedly 10 (partial (mg/generate [:=> [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + boolean)))) + (is (= '(-11901892 -5288 -85 -1 -1380 479 -28741703 57202930 0 -46414) + (map #(%1 %2) + (repeatedly (mg/generate [:=> :cat [:=> [:cat :int] :int]] {:seed 1 :size 30})) + (range 10))))) + +(deftest deterministic-impure-fn-gen-test + (is (= '(0 -1 0 -3 0 1 16 0 7 3) + (repeatedly 10 (partial (mg/generate [:=> {:gen/impure true} [:cat :int] :int] {:seed 0 :size 10}) 2)))) + ;;TODO make more interesting results + (is (= '(-1 0 1 -2 1 -1 -2 -4 0 -113) + (map (mg/generate [:=> {:gen/impure true} [:cat :int] :int] {:seed 1 :size 30}) (range 10)) + (repeatedly 10 (partial (mg/generate [:=> {:gen/impure true} [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + identity)) + (repeatedly 10 (partial (mg/generate [:=> {:gen/impure true} [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + str)) + (repeatedly 10 (partial (mg/generate [:=> {:gen/impure true} [:cat [:=> [:cat :any] :any]] :int] {:seed 1 :size 30}) + boolean)))) + (is (= '(-11901892 -5288 -85 -1 -1380 479 -28741703 57202930 0 -46414) + (map #(%1 %2) + (repeatedly (mg/generate [:=> :cat [:=> [:cat :int] :int]] {:seed 1 :size 30})) + (range 10))))) +(comment +;; This sequence of results should be reproducible. +(def pure (mg/generate [:=> [:cat :int] :int] {:seed 0 :size 10})) +(def impure (mg/generate [:=> {:gen/impure true} [:cat :int] :int] {:seed 0 :size 10})) +(repeatedly 10 #(pure 2)) +;=> (-106 -106 -106 -106 -106 -106 -106 -106 -106 -106) +(repeatedly 10 #(pure 2)) +;=> (-106 -106 -106 -106 -106 -106 -106 -106 -106 -106) +(repeatedly 10 #(impure 2)) +;=> (0 -1 0 -3 0 1 16 0 7 3) +(repeatedly 10 #(impure 2)) +;=> (0 -1 -1 1 2 3 -2 38 -5 -12) + +(mapv pure (range 10)) +;=> [5 511 -106 20 -51 -322 1 0 434 -1] +(mapv pure (range 10)) +;=> [5 511 -106 20 -51 -322 1 0 434 -1] +(mapv impure (range 10)) +;=> [-1 0 -2 -4 -3 -4 -15 -15 -16 -2] +(mapv impure (range 10)) +;=> [-1 -1 -1 0 1 3 -12 30 -2 1] +)