Merge pull request #792 from frenchy64/frenchy64-recursive-non-termination

Fix recursive `:+` generators

Author: ikitommi

src/malli/generator.cljc

@@ -1,3 +1,6 @@
+;; See also `malli.generator-ast` for viewing generators as data
+;; Note: use `::mg/foo` instead of `::foo` in this namespace
+;; to assist in generating `malli.generator-ast`.
 (ns malli.generator
   (:require [clojure.spec.gen.alpha :as ga]
             [clojure.string :as str]
@@ -8,6 +11,7 @@
             [clojure.test.check.rose-tree :as rose]
             [malli.core :as m]
             [malli.registry :as mr]
+            [malli.generator :as-alias mg]
             #?(:clj [borkdude.dynaload :as dynaload])))
 
 (declare generator generate -create)
@@ -48,7 +52,7 @@
 
 (defn -never-gen
   "Return a generator of no values that is compatible with -unreachable-gen?."
-  [{::keys [original-generator-schema] :as _options}]
+  [{::mg/keys [original-generator-schema] :as _options}]
   (with-meta (gen/such-that (fn [_]
                               (throw (ex-info
                                       (str "Cannot generate values due to infinitely expanding schema: "
@@ -58,12 +62,12 @@
                                       (cond-> {}
                                         original-generator-schema (assoc :schema (m/form original-generator-schema))))))
                             gen/any)
-             {::never-gen true
-              ::original-generator-schema original-generator-schema}))
+             {::mg/never-gen true
+              ::mg/original-generator-schema original-generator-schema}))
 
 (defn -unreachable-gen?
   "Returns true iff generator g generators no values."
-  [g] (-> (meta g) ::never-gen boolean))
+  [g] (-> (meta g) ::mg/never-gen boolean))
 
 (defn -not-unreachable [g] (when-not (-unreachable-gen? g) g))
 
@@ -80,9 +84,9 @@
 (defn -min-max [schema options]
   (let [{:keys [min max] gen-min :gen/min gen-max :gen/max} (m/properties schema options)]
     (when (and min gen-min (< gen-min min))
-      (m/-fail! ::invalid-property {:key :gen/min, :value gen-min, :min min}))
+      (m/-fail! ::mg/invalid-property {:key :gen/min, :value gen-min, :min min}))
     (when (and max gen-max (> gen-max max))
-      (m/-fail! ::invalid-property {:key :gen/max, :value gen-min, :max min}))
+      (m/-fail! ::mg/invalid-property {:key :gen/max, :value gen-min, :max min}))
     {:min (or gen-min min)
      :max (or gen-max max)}))
 
@@ -286,12 +290,12 @@
 
 (defn -ref-gen [schema options]
   (let [ref-id (-identify-ref-schema schema)]
-    (or (force (get-in options [::rec-gen ref-id]))
+    (or (force (get-in options [::mg/rec-gen ref-id]))
         (let [scalar-ref-gen (delay (-never-gen options))
               dschema (m/deref schema)]
-          (cond->> (generator dschema (assoc-in options [::rec-gen ref-id] scalar-ref-gen))
+          (cond->> (generator dschema (assoc-in options [::mg/rec-gen ref-id] scalar-ref-gen))
             (realized? scalar-ref-gen) (gen/recursive-gen
-                                        #(generator dschema (assoc-in options [::rec-gen ref-id] %))))))))
+                                        #(generator dschema (assoc-in options [::mg/rec-gen ref-id] %))))))))
 
 (defn -=>-gen [schema options]
   (let [output-generator (generator (:output (m/-function-info schema)) options)]
@@ -334,12 +338,21 @@
       (gen/return ()))))
 
 (defn -*-gen [schema options]
-  (let [child (m/-get schema 0 nil)]
+  (let [child (m/-get schema 0 nil)
+        mode (::mg/-*-gen-mode options :*)
+        options (dissoc options ::mg/-*-gen-mode)]
     (if-some [g (-not-unreachable (generator child options))]
       (cond->> (gen/vector g)
         (m/-regex-op? child)
         (gen/fmap #(apply concat %)))
-      (gen/return ()))))
+      (case mode
+        :* (gen/return ())
+        :+ (-never-gen options)))))
+
+(defn -+-gen [schema options]
+  (let [g (-*-gen schema (assoc options ::mg/-*-gen-mode :+))]
+    (cond-> g
+      (-not-unreachable g) gen/not-empty)))
 
 (defn -repeat-gen [schema options]
   (let [child (m/-get schema 0 nil)]
@@ -360,9 +373,9 @@
 (defn -qualified-symbol-gen [schema]
   (-qualified-ident-gen schema symbol gen/symbol qualified-symbol? gen/symbol-ns))
 
-(defmulti -schema-generator (fn [schema options] (m/type schema options)) :default ::default)
+(defmulti -schema-generator (fn [schema options] (m/type schema options)) :default ::mg/default)
 
-(defmethod -schema-generator ::default [schema options] (ga/gen-for-pred (m/validator schema options)))
+(defmethod -schema-generator ::mg/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)}))
 (defmethod -schema-generator :>= [schema options] (-double-gen {:min (-> schema (m/children options) first)}))
@@ -432,7 +445,7 @@
 
 (defmethod -schema-generator :? [schema options] (-?-gen schema options))
 (defmethod -schema-generator :* [schema options] (-*-gen schema options))
-(defmethod -schema-generator :+ [schema options] (gen/not-empty (-*-gen schema options)))
+(defmethod -schema-generator :+ [schema options] (-+-gen schema options))
 (defmethod -schema-generator :repeat [schema options] (-repeat-gen schema options))
 
 ;;
@@ -448,7 +461,7 @@
       (when-not (:gen/elements props)
         (if (satisfies? Generator schema)
           (-generator schema options)
-          (-schema-generator schema (assoc options ::original-generator-schema schema))))))
+          (-schema-generator schema (assoc options ::mg/original-generator-schema schema))))))
 
 (defn- -create-from-schema [props options]
   (some-> (:gen/schema props) (generator options)))
@@ -468,8 +481,8 @@
         (-create-from-elements props)
         (-create-from-schema props options)
         (-create-from-gen props schema options)
-        (m/-fail! ::no-generator {:options options
-                                  :schema schema}))))
+        (m/-fail! ::mg/no-generator {:options options
+                                     :schema schema}))))
 
 ;;
 ;; public api
@@ -479,7 +492,7 @@
   ([?schema]
    (generator ?schema nil))
   ([?schema options]
-   (if (::rec-gen options)
+   (if (::mg/rec-gen options)
      ;; disable cache while calculating recursive schemas. caches don't distinguish options.
      (-create (m/schema ?schema options) options)
      (m/-cached (m/schema ?schema options) :generator #(-create % options)))))
@@ -507,7 +520,7 @@
 
 (defn function-checker
   ([?schema] (function-checker ?schema nil))
-  ([?schema {::keys [=>iterations] :or {=>iterations 100} :as options}]
+  ([?schema {::mg/keys [=>iterations] :or {=>iterations 100} :as options}]
    (let [schema (m/schema ?schema options)
          check (fn [schema]
                  (let [{:keys [input output]} (m/-function-info schema)
@@ -524,15 +537,15 @@
                                           (try (apply f smallest) (catch #?(:clj Exception, :cljs js/Error) e e)))
                                explain-output (when-not explain-input (m/explain output response))]
                            (cond-> shrunk
-                             explain-input (assoc ::explain-input explain-input)
-                             explain-output (assoc ::explain-output explain-output)
+                             explain-input (assoc ::mg/explain-input explain-input)
+                             explain-output (assoc ::mg/explain-output explain-output)
                              (ex-message result) (-> (update :result ex-message)
                                                      (dissoc :result-data)))))))))]
      (condp = (m/type schema)
        :=> (check schema)
        :function (let [checkers (map #(function-checker % options) (m/-children schema))]
                    (fn [x] (->> checkers (keep #(% x)) (seq))))
-       (m/-fail! ::invalid-function-schema {:type (m/-type schema)})))))
+       (m/-fail! ::mg/invalid-function-schema {:type (m/-type schema)})))))
 
 (defn check
   ([?schema f] (check ?schema f nil))

test/malli/generator_ast.clj

@@ -0,0 +1,27 @@
+(ns malli.generator-ast
+  "For inspecting a malli's generator as data. See `generator-ast`"
+  (:require [clojure.java.io :as io]
+            [clojure.string :as str]
+            [clojure.walk :as walk]
+            [malli.generator :as mg]))
+
+(let [s (-> (slurp (io/resource "malli/generator.cljc"))
+            ;; change the namespace
+            (str/replace-first "(ns malli.generator" "(ns malli.generator-ast")
+            ;; change the `gen` alias to the AST version
+            (str/replace-first "clojure.test.check.generators" "malli.generator-debug"))]
+  ;; eval ns form first so keywords can be resolved in the right namespace
+  (eval (read-string {:read-cond :allow :features #{:clj}} s))
+  (eval (read-string {:read-cond :allow :features #{:clj}} (str "(do " s ")"))))
+
+(defn generator-ast
+  "Return a malli schema's generator as an AST."
+  ([?schema]
+   (generator-ast ?schema nil))
+  ([?schema options]
+   (walk/postwalk
+     (fn [g]
+       (if (mg/-unreachable-gen? g)
+         {:op :unreachable}
+         g))
+     (generator ?schema (assoc options ::mg/generator-ast true)))))

test/malli/generator_ast_test.clj

@@ -0,0 +1,74 @@
+(ns malli.generator-ast-test
+  (:require [clojure.pprint :refer [pprint]]
+            [clojure.test :refer [are deftest is testing]]
+            [malli.generator-ast :as ast]))
+
+(deftest generator-ast-test
+  (is (= '{:op :recursive-gen,
+           :rec-gen
+           {:op :one-of,
+            :generators
+            [{:op :boolean}
+             {:op :tuple,
+              :generators [{:op :elements, :coll [:not]} {:op :boolean}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:and]}
+               {:op :vector, :generator {:op :recur}}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:or]}
+               {:op :vector, :generator {:op :recur}}]}]},
+           :scalar-gen
+           {:op :one-of,
+            :generators
+            [{:op :boolean}
+             {:op :tuple,
+              :generators [{:op :elements, :coll [:not]} {:op :boolean}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:and]} {:op :return, :value ()}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:or]} {:op :return, :value ()}]}]}}
+         (ast/generator-ast
+           [:schema
+            {:registry
+             {::formula
+              [:or
+               :boolean
+               [:tuple [:enum :not] :boolean]
+               [:tuple [:enum :and] [:* [:ref ::formula]]]
+               [:tuple [:enum :or]  [:* [:ref ::formula]]]]}}
+            [:ref ::formula]])))
+  (is (= '{:op :recursive-gen,
+           :rec-gen
+           {:op :one-of,
+            :generators
+            [{:op :boolean}
+             {:op :tuple,
+              :generators [{:op :elements, :coll [:not]} {:op :boolean}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:and]}
+               {:op :not-empty, :gen {:op :vector, :generator {:op :recur}}}]}
+             {:op :tuple,
+              :generators
+              [{:op :elements, :coll [:or]}
+               {:op :not-empty, :gen {:op :vector, :generator {:op :recur}}}]}]},
+           :scalar-gen
+           {:op :one-of,
+            :generators
+            [{:op :boolean}
+             {:op :tuple,
+              :generators [{:op :elements, :coll [:not]} {:op :boolean}]}]}}
+         (ast/generator-ast
+           [:schema
+            {:registry
+             {::formula
+              [:or
+               :boolean
+               [:tuple [:enum :not] :boolean]
+               [:tuple [:enum :and] [:+ [:ref ::formula]]]
+               [:tuple [:enum :or]  [:+ [:ref ::formula]]]]}}
+            [:ref ::formula]]))))

test/malli/generator_debug.cljc

@@ -0,0 +1,43 @@
+(ns malli.generator-debug
+  "Drop-in replacement for clojure.test.check.generators that returns AST's
+  instead of generators."
+  (:refer-clojure :exclude [vector char keyword boolean not-empty symbol]))
+
+(defmacro such-that [& args] (let [args (vec args)] `{:op :such-that :args-form '~args :args ~args}))
+(def any {:op :any})
+(def any-printable {:op :any-printable})
+(defn double* [& args] {:op :double* :args args})
+(defmacro fmap [& args] (let [args (vec args)] `{:op :fmap :args-form '~args :args ~args}))
+(defmacro vector
+  ([generator] {:op :vector :generator generator})
+  ([generator num-elements] {:op :vector :generator generator :num-elements num-elements})
+  ([generator min-elements max-elements]
+   {:op :vector :generator generator :min-elements min-elements :max-elements max-elements}))
+(defmacro vector-distinct [& args] (let [args (vec args)] `{:op :vector-distinct :args-form '~args :args ~args}))
+(def char {:op :char})
+(def nat {:op :nat})
+(def char-alphanumeric {:op :char-alphanumeric})
+(def string-alphanumeric {:op :string-alphanumeric})
+(defn sized [& args] {:op :sized :args args})
+(defn return [value] {:op :return :value value})
+(defn one-of [generators] {:op :one-of :generators generators})
+(defn tuple [& generators] {:op :tuple :generators (vec generators)})
+(defn recursive-gen [rec scalar]
+  {:op :recursive-gen
+   :rec-gen (rec {:op :recur})
+   :scalar-gen scalar})
+(def keyword {:op :keyword})
+(def keyword-ns {:op :keyword-ns})
+(def symbol {:op :symbol})
+(def symbol-ns {:op :symbol-ns})
+(def s-pos-int {:op :s-pos-int})
+(def s-neg-int {:op :s-neg-int})
+(defn elements [coll] {:op :elements :coll coll})
+(defn large-integer* [& args] {:op :large-integer* :args args})
+(def boolean {:op :boolean})
+(def uuid {:op :uuid})
+(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-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"))

test/malli/generator_test.cljc

@@ -624,6 +624,48 @@
                                               (gen/tuple (gen/return :B))
                                               (gen/tuple (gen/return :C))
                                               (gen/tuple (gen/return :D))])))
+                    {:seed 0})))
+  (is (= '([:not true] [:not false] [:and [[:not false]]] [:or [[:not false]]] false [:and [true [:not true]]] [:and ()] [:or [[:or ()] false]] [:not true] [:and [[:not true]]])
+         (mg/sample [:schema
+                     {:registry
+                      {::formula
+                       [:or
+                        :boolean
+                        [:tuple [:enum :not] :boolean]
+                        [:tuple [:enum :and] [:* [:ref ::formula]]]
+                        [:tuple [:enum :or]  [:* [:ref ::formula]]]]}}
+                     [:ref ::formula]]
+                    {:seed 0})
+         (mg/sample (gen/recursive-gen
+                      (fn [formula]
+                        (gen/one-of [gen/boolean
+                                     (gen/tuple (gen/elements [:not]) gen/boolean)
+                                     (gen/tuple (gen/elements [:and]) (gen/vector formula))
+                                     (gen/tuple (gen/elements [:or]) (gen/vector formula))]))
+                      (gen/one-of [gen/boolean
+                                   (gen/tuple (gen/elements [:not]) gen/boolean)
+                                   (gen/tuple (gen/elements [:and]) (gen/return ()))
+                                   (gen/tuple (gen/elements [:or]) (gen/return ()))]))
+                    {:seed 0})))
+  (is (= '([:not true] [:not false] [:and [true]] [:or [[:not false] true]] false [:and [[:not true]]] [:not false] [:or [[:not false] [:not true]]] [:not true] [:and [[:not false] [:and [[:not false] [:not true]]] [:and [[:not true]]]]])
+         (mg/sample [:schema
+                     {:registry
+                      {::formula
+                       [:or
+                        :boolean
+                        [:tuple [:enum :not] :boolean]
+                        [:tuple [:enum :and] [:+ [:ref ::formula]]]
+                        [:tuple [:enum :or]  [:+ [:ref ::formula]]]]}}
+                     [:ref ::formula]]
+                    {:seed 0})
+         (mg/sample (gen/recursive-gen
+                      (fn [formula]
+                        (gen/one-of [gen/boolean
+                                     (gen/tuple (gen/elements [:not]) gen/boolean)
+                                     (gen/tuple (gen/elements [:and]) (gen/not-empty (gen/vector formula)))
+                                     (gen/tuple (gen/elements [:or]) (gen/not-empty (gen/vector formula)))]))
+                      (gen/one-of [gen/boolean
+                                   (gen/tuple (gen/elements [:not]) gen/boolean)]))
                     {:seed 0}))))
 
 (deftest infinite-generator-test