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 c371dc7 commit f80e33a
Show file tree
Hide file tree
Showing 2 changed files with 57 additions and 33 deletions.
10 changes: 5 additions & 5 deletions src/malli/constraint/solver.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,9 +42,9 @@
)

(defn -type-constraints [all-sols]
(when-some [types (not-empty (into #{} (mapcat :type) all-sols))]
(when-some [types (not-empty (into #{} (map :type) all-sols))]
(let [remove-redundant (reduce (fn [acc t] (apply disj acc (type-supers t))) types types)]
[{:type remove-redundant}])))
(mapv #(hash-map :type %) remove-redundant))))

(defn -conj-type-constraints [all-sols]
(or (-type-constraints all-sols)
Expand Down Expand Up @@ -138,11 +138,11 @@ collected."
{gen-min :gen/min gen-max :gen/max} (when (= :gen mode) (m/properties constraint))]
(-min-max min max gen-min gen-max :min-count :max-count)))

(defmethod -constraint-solutions* :<= [constraint options] [{:type #{:number} :max-range (first (m/children constraint))}])
(defmethod -constraint-solutions* :>= [constraint options] [{:type #{:number} :min-range (first (m/children constraint))}])
(defmethod -constraint-solutions* :<= [constraint options] [{:type :number :max-range (first (m/children constraint))}])
(defmethod -constraint-solutions* :>= [constraint options] [{:type :number :min-range (first (m/children constraint))}])
(defmethod -constraint-solutions* :int [constraint {::keys [mode] :as options}]
(let [{gen-min :gen/min gen-max :gen/max :keys [min max]} (m/properties constraint)]
[(cond-> {:type #{:int}}
[(cond-> {:type :int}
min (assoc :min-range min)
max (assoc :max-range max)
(= :gen mode) (cond->
Expand Down
80 changes: 52 additions & 28 deletions src/malli/generator.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -89,9 +89,25 @@
{:min (or gen-min min)
:max (or gen-max max)}))

(defn- -double-gen [goptions options]
(defn- -float-gen* [goptions options]
(->> (gen/double* (merge {:infinite? false, :NaN? false} goptions))
(gen/fmap float)))

(defn- -double-gen* [goptions {::keys [solution] :as options}]
(prn "solution" solution)
(gen/double* (merge {:infinite? false, :NaN? false} goptions)))

(defn- -int-gen* [goptions {::keys [solution] :as options}]
(if-some [{:keys [min-range max-range]} solution]
(gen/large-integer* (cond-> goptions
(integer? min-range) (update :min #(if %
(max % min-range)
min-range))
(integer? max-range) (update :max #(if %
(min % max-range)
max-range))))
(gen/large-integer* goptions)))

(defn- gen-vector-min [gen min options]
(cond-> (gen/sized #(gen/vector gen min (+ min %)))
(::generator-ast options) (vary-meta assoc ::generator-ast
Expand Down Expand Up @@ -172,16 +188,24 @@
;; can still use such-that but should never fail.

(defn -and-gen [schema options]
(let [[gchild & schildren] (m/children options)
options (update options ::solution #(cond-> (solver/-solve-constraints schildren options)
% (solver/-conj-solutions %)))]
(if-some [gen (-not-unreachable (generator gchild options))]
(gen/such-that (m/validator schema options) gen
(let [[gchild & schildren] (m/children schema)
solutions (cond-> (solver/-solve-constraints schildren options)
(::solution options) (solver/-conj-solutions [(::solution options)]))]
(if-some [gens (seq (keep #(-not-unreachable (generator gchild (assoc options ::solution %)))
solutions))]
(gen/such-that (m/validator schema options) (gen-one-of gens)
{:max-tries 100
:ex-fn #(m/-exception ::and-generator-failure
(assoc % :schema schema))})
(-never-gen options))))

(comment
(do (sample [:and :int [:>= 1] [:<= 1]] {:size 1000})
nil)
(do (sample [:and :int [:>= 1] [:<= 1]] {:size 1000})
nil)
)

(defn- gen-one-of [gs]
(if (= 1 (count gs))
(first gs)
Expand Down Expand Up @@ -478,16 +502,16 @@

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

(defmethod -schema-generator :> [schema options] (-double-gen {:min (-> schema (m/children options) first inc)} options))
(defmethod -schema-generator :>= [schema options] (-double-gen {:min (-> schema (m/children options) first)} options))
(defmethod -schema-generator :< [schema options] (-double-gen {:max (-> schema (m/children options) first dec)} options))
(defmethod -schema-generator :<= [schema options] (-double-gen {:max (-> schema (m/children options) first)} options))
(defmethod -schema-generator :> [schema options] (-double-gen* {:min (-> schema (m/children options) first inc)} options))
(defmethod -schema-generator :>= [schema options] (-double-gen* {:min (-> schema (m/children options) first)} options))
(defmethod -schema-generator :< [schema options] (-double-gen* {:max (-> schema (m/children options) first dec)} options))
(defmethod -schema-generator :<= [schema options] (-double-gen* {:max (-> schema (m/children options) first)} options))
(defmethod -schema-generator := [schema options] (gen/return (first (m/children schema options))))
(defmethod -schema-generator :not= [schema options] (gen/such-that #(not= % (-> schema (m/children options) first)) gen/any-printable
{:max-tries 100
:ex-fn #(m/-exception ::not=-generator-failure (assoc % :schema schema))}))
(defmethod -schema-generator 'pos? [_ options] (gen/one-of [(-double-gen {:min 0.00001} options) (gen/fmap inc gen/nat)]))
(defmethod -schema-generator 'neg? [_ options] (gen/one-of [(-double-gen {:max -0.0001} options) (gen/fmap (comp dec -) gen/nat)]))
(defmethod -schema-generator 'pos? [_ options] (gen/one-of [(-double-gen* {:min 0.00001} options) (gen/fmap inc gen/nat)]))
(defmethod -schema-generator 'neg? [_ options] (gen/one-of [(-double-gen* {:max -0.0001} options) (gen/fmap (comp dec -) gen/nat)]))

(defmethod -schema-generator :not [schema options] (gen/such-that (m/validator schema options) (ga/gen-for-pred any?)
{:max-tries 100
Expand Down Expand Up @@ -521,29 +545,29 @@
(defmethod -schema-generator :some [_ _] gen/any-printable)
(defmethod -schema-generator :nil [_ _] nil-gen)
(defmethod -schema-generator :string [schema options] (-string-gen schema options))
(defmethod -schema-generator :int [schema options] (gen/large-integer* (-min-max schema options)))
(defmethod -schema-generator :int [schema options] (-int-gen* (-min-max schema options) options))
(defmethod -schema-generator :double [schema options]
(gen/double* (merge (let [props (m/properties schema options)]
{:infinite? (get props :gen/infinite? false)
:NaN? (get props :gen/NaN? false)})
(-> (-min-max schema options)
(update :min #(some-> % double))
(update :max #(some-> % double))))))
(-double-gen* (merge (let [props (m/properties schema options)]
{:infinite? (get props :gen/infinite? false)
:NaN? (get props :gen/NaN? false)})
(-> (-min-max schema options)
(update :min #(some-> % double))
(update :max #(some-> % double))))
options))
(defmethod -schema-generator :float [schema options]
(let [max-float #?(:clj Float/MAX_VALUE :cljs (.-MAX_VALUE js/Number))
min-float (- max-float)
props (m/properties schema options)
min-max-props (-min-max schema options)
infinite? #?(:clj false :cljs (get props :gen/infinite? false))]
(->> (merge {:infinite? infinite?
:NaN? (get props :gen/NaN? false)}
(-> min-max-props
(update :min #(or (some-> % float)
#?(:clj min-float :cljs nil)))
(update :max #(or (some-> % float)
#?(:clj max-float :cljs nil)))))
(gen/double*)
(gen/fmap float))))
(-float-gen* (merge {:infinite? infinite?
:NaN? (get props :gen/NaN? false)}
(-> min-max-props
(update :min #(or (some-> % float)
#?(:clj min-float :cljs nil)))
(update :max #(or (some-> % float)
#?(:clj max-float :cljs nil)))))
options)))
(defmethod -schema-generator :boolean [_ _] gen/boolean)
(defmethod -schema-generator :keyword [_ _] gen/keyword)
(defmethod -schema-generator :symbol [_ _] gen/symbol)
Expand Down

0 comments on commit f80e33a

Please sign in to comment.