Skip to content

Commit

Permalink
wip
Browse files Browse the repository at this point in the history
  • Loading branch information
@frenchy64
frenchy64 committed Nov 23, 2024
1 parent d9646da commit 87fbeb6
Showing 1 changed file with 59 additions and 89 deletions.
148 changes: 59 additions & 89 deletions src/malli/generator.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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"))
Expand Down Expand Up @@ -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 %)))
Expand Down Expand Up @@ -170,80 +183,37 @@
: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))})
(-never-gen options))))

(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
[:and [:>= 2] [:<= 2]]
[: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]
Expand Down

0 comments on commit 87fbeb6

Please sign in to comment.