From 87fbeb674eacf17d2e292a07c7dd364745034251 Mon Sep 17 00:00:00 2001 From: Ambrose Bonnaire-Sergeant Date: Sat, 23 Nov 2024 01:27:03 -0600 Subject: [PATCH] wip --- src/malli/generator.cljc | 148 ++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 89 deletions(-) diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index 543b723b0..9509109ab 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -17,7 +17,7 @@ [malli.impl.util :refer [-last -merge]] #?(:clj [borkdude.dynaload :as dynaload]))) -(declare generator generate -create) +(declare generator generate -create gen-one-of) (defprotocol Generator (-generator [this options] "returns generator for schema")) @@ -90,42 +90,55 @@ {:min (or gen-min min) :max (or gen-max max)})) +(defn- -solve-each [f {::keys [solutions] :as options}] + (->> (or solutions [{}]) + (mapv f) + gen-one-of)) + (defn- -float-gen* [goptions options] + ;;TODO (->> (gen/double* (merge {:infinite? false, :NaN? false} goptions)) (gen/fmap float))) -(defn- -double-gen* [goptions {{:keys [min-range max-range] :as solution} ::solution :as options}] - (prn "-double-gen* solution" solution) - (let [goptions (merge {:infinite? false, :NaN? false} goptions)] - (gen/double* (cond-> (merge {:infinite? false, :NaN? false} goptions) - solution (cond-> - min-range (update :min #(let [;; TODO more thorough bounds checking - min-range (double min-range)] - (if % - (max % min-range) - min-range))) - max-range (update :max #(let [max-range (double max-range)] - (if % - (min % max-range) - max-range)))))))) - -(defn- -int-gen* [goptions {{:keys [min-range max-range] :as solution} ::solution :as options}] - (prn "-int-gen* solution" solution) - (let [{:keys [min max] :as goptions} (cond-> goptions - solution - (cond-> - min-range (update :min #(let [;; TODO more thorough bounds checking - min-range (long (math/ceil min-range))] - (if % - (max % min-range) - min-range))) - max-range (update :max #(let [max-range (long (math/floor max-range))] - (if % - (min % max-range) - max-range)))))] - (if (and min max (not (<= min max))) - (-never-gen options) - (gen/large-integer* goptions)))) +(defn- -double-gen* [goptions options] + (-solve-each + (fn [{:keys [min-range max-range] :as solution}] + (let [{:keys [min max] :as goptions} + (cond-> (merge {:infinite? false, :NaN? false} goptions) + solution (cond-> + min-range (update :min #(let [;; TODO more thorough bounds checking + min-range (double min-range)] + (if % + (max % min-range) + min-range))) + max-range (update :max #(let [max-range (double max-range)] + (if % + (min % max-range) + max-range)))))] + (if (and min max (not (<= min max))) + (-never-gen options) + (gen/double* goptions)))) + options)) + +(defn- -int-gen* [goptions options] + (-solve-each + (fn [{:keys [min-range max-range] :as solution}] + (let [{:keys [min max] :as goptions} (cond-> goptions + solution + (cond-> + min-range (update :min #(let [;; TODO more thorough bounds checking + min-range (long (math/ceil min-range))] + (if % + (max % min-range) + min-range))) + max-range (update :max #(let [max-range (long (math/floor max-range))] + (if % + (min % max-range) + max-range)))))] + (if (and min max (not (<= min max))) + (-never-gen options) + (gen/large-integer* goptions)))) + options)) (defn- gen-vector-min [gen min options] (cond-> (gen/sized #(gen/vector gen min (+ min %))) @@ -170,53 +183,12 @@ :ex-fn #(m/-exception ::distinct-generator-failure (assoc % :schema schema))}))))) -(declare gen-one-of) - -(defn- -constraint-solutions [constraint options] - (solver/-constraint-solutions constraint (assoc options ::solver/mode :gen))) - -(defn- -solve-schema-constraints [schema options] - (let [constraint (or (mc/-get-constraint schema) - (m/-fail! ::missing-constraint {:type (m/type schema) - :schema schema})) - solutions (-constraint-solutions constraint options)] - (when (empty? solutions) - (m/-fail! ::unsatisfiable-constraint {:type (m/type schema) - :schema schema - :constraint constraint})) - solutions)) - -(defn- -solutions-gen [schema solution->gen options] - (->> (-solve-schema-constraints schema options) - (mapv solution->gen) - gen-one-of)) - -(defn- -min-max-solutions-gen [schema options mink maxk min-max->gen] - (-solutions-gen schema - (fn [solution] - (when-some [unsupported-keys (not-empty (disj (set (keys solution)) - mink maxk))] - (m/-fail! ::unsupported-constraint-solution {:type (m/type schema) - :schema schema - :solution solution})) - (min-max->gen (set/rename-keys solution {mink :min maxk :max}))) - options)) - -;; simplify [:and :int [:<= 4]] => [:int {:max 4}] before generating -;; or add constraint solutions to options that final generator uses for hints -;; can still use such-that but should never fail. - (defn -and-gen [schema options] (let [[gchild & schildren] (m/children schema) - _ (prn "schildren" schildren) solutions (cond-> (solver/-solve-constraints schildren options) - (::solution options) (solver/-conj-solutions [(::solution options)]))] - (prn "solutions" solutions) - (if-some [gens (not-empty - (keep #(-not-unreachable (generator gchild (assoc options ::solution %))) - solutions))] - (gen/such-that (m/validator schema options) (gen-one-of (doto gens - (prn "gens"))) + (::solutions options) (apply solver/-conj-solutions (::solutions options)))] + (if-some [gen (-not-unreachable (generator gchild (assoc options ::solutions solutions)))] + (gen/such-that (m/validator schema options) gen {:max-tries 100 :ex-fn #(m/-exception ::and-generator-failure (assoc % :schema schema))}) @@ -224,19 +196,14 @@ (comment ;; unsatisfiable - (do (sample [:and :int [:>= 1.5] [:<= 1.5]] {:size 1000}) - nil) + (sample [:and :int [:>= 1.5] [:<= 1.5]] {:size 1000}) (assert (= #{1} (set (sample [:and :int [:>= 1] [:<= 1]] {:size 1000})))) - ;;FIXME never generates 2 - (do (sample [:and :int [:or - [:and [:>= 1] [:<= 1]] - [:and [:>= 2] [:<= 2]]]] {:size 10}) - nil) - ;;FIXME never generates 1 - (do (set (sample [:and :int [:or - [:and [:>= 2] [:<= 2]] - [:and [:>= 1] [:<= 1]]]] {:size 100000})) - nil) + (assert (= #{1 2} (set (sample [:and :int [:or + [:and [:>= 1] [:<= 1]] + [:and [:>= 2] [:<= 2]]]] {:size 1000})))) + (assert (= #{1 2} (set (sample [:and :int [:or + [:and [:>= 2] [:<= 2]] + [:and [:>= 1] [:<= 1]]]] {:size 100000})))) (assert (= #{2 3} (set (distinct (sample [:and :int [:>= 2] [:and [:or [:<= 3] [:<= 2]]]] {:size 100000}))))) (assert (= #{2 2.0 1 1.0}) (set (sample [:or @@ -244,6 +211,9 @@ [:and [:>= 1] [:<= 1]]] {:size 100000}))) (assert (= #{2 2.0} (set (sample [:and [:>= 2] [:<= 2]] {:size 100000})))) (assert (every? #(< 2 % 3) (sample [:and [:> 2] [:< 3]] {:size 100000}))) + (assert (every? #(and (< 2 %) (<= % 3)) (sample [:and [:> 2] [:<= 3]] {:size 100000}))) + (assert (some #{3.0} (sample [:and [:> 2] [:<= 3]] {:size 100000}))) + (assert (every? #(and (<= 2 %) (< % 3)) (sample [:and [:>= 2] [:< 3]] {:size 100000}))) ) (defn- gen-one-of [gs]