Add test.check support

bb/tasks.clj

@@ -27,6 +27,10 @@
         set-config (edn/read-string (slurp (io/resource "cherry/clojure.set.edn")))
         pprint-config (edn/read-string (slurp (io/resource "cherry/clojure.pprint.edn")))
         test-config (edn/read-string (slurp (io/resource "cherry/cherry.test.edn")))
+        check-config (edn/read-string (slurp (io/resource "cherry/clojure.test.check.edn")))
+        gen-config (edn/read-string (slurp (io/resource "cherry/clojure.test.check.generators.edn")))
+        prop-config (edn/read-string (slurp (io/resource "cherry/clojure.test.check.properties.edn")))
+        clojure-test-config (edn/read-string (slurp (io/resource "cherry/clojure.test.check.clojure_test.edn")))
         reserved (edn/read-string (slurp (io/resource "cherry/js_reserved.edn")))]
     {:modules
      {:cljs.core {:exports (assoc (->namespace "cljs.core" (:vars core-config) reserved)
@@ -45,7 +49,13 @@
                     :depends-on #{:cljs.core :clojure.string}}
       :clojure.test {:exports (->namespace "cherry.test" (:vars test-config) reserved)
                      :entries '[cherry.test]
-                     :depends-on #{:cljs.core :clojure.string}}}}))
+                     :depends-on #{:cljs.core :clojure.string}}
+      :clojure.test.check {:exports (merge (->namespace "clojure.test.check" (:vars check-config) reserved)
+                                           (->namespace "clojure.test.check.generators" (:vars gen-config) reserved)
+                                           (->namespace "clojure.test.check.properties" (:vars prop-config) reserved)
+                                           (->namespace "clojure.test.check.clojure-test" (:vars clojure-test-config) reserved))
+                           :entries '[clojure.test.check clojure.test.check.generators clojure.test.check.properties clojure.test.check.clojure-test]
+                           :depends-on #{:cljs.core :clojure.string :cljs.pprint}}}}))
 
 (def test-config
   '{:compiler-options {:load-tests true}

deps.edn

@@ -3,17 +3,19 @@
         org.babashka/sci {:mvn/version "0.10.49"}
         io.github.squint-cljs/squint
         #_{:local/root "/Users/borkdude/dev/squint"}
-        {:git/sha "9ad6e7b6106c93fd58cd3c1358d5838cce85db28"}}
+        {:git/sha "5abc27fcb1c47e97aff39ce539f52d0e54dd30a8"}}
  :aliases
  {:cljs {:extra-paths ["test"]
          :extra-deps {thheller/shadow-cljs {:mvn/version "3.3.4"}
                       funcool/promesa {:mvn/version "11.0.678"}
-                      babashka/process {:mvn/version "0.6.23"}}}
+                      babashka/process {:mvn/version "0.6.23"}
+                      org.clojure/test.check {:mvn/version "1.1.3"}}}
   :test ;; added by neil
   {:extra-paths ["test"]
    :extra-deps {io.github.cognitect-labs/test-runner
                 {:git/tag "v0.5.1" :git/sha "dfb30dd" :git/url "https://github.com/cognitect-labs/test-runner"}
-                babashka/fs {:mvn/version "0.5.27"}}
+                babashka/fs {:mvn/version "0.5.27"}
+                org.clojure/test.check {:mvn/version "1.1.3"}}
    :main-opts ["-m" "cognitect.test-runner"]
    :exec-fn cognitect.test-runner.api/test}}
  }

resources/cherry/clojure.test.check.clojure_test.edn

@@ -0,0 +1,11 @@
+{:vars #{default_reporter_fn
+         _STAR_default_test_count_STAR_
+         _STAR_default_opts_STAR_
+         _STAR_report_shrinking_STAR_
+         _STAR_report_trials_STAR_
+         _STAR_report_completion_STAR_
+         _STAR_trial_report_period_STAR_
+         trial_report_dots
+         trial_report_periodic
+         assert_check
+         process_options}}

resources/cherry/clojure.test.check.edn

@@ -0,0 +1 @@
+{:vars #{quick_check}}

resources/cherry/clojure.test.check.generators.edn

@@ -0,0 +1,57 @@
+{:vars #{any
+         any_printable
+         any_printable_ascii
+         bind
+         boolean
+         byte
+         bytes
+         char
+         char_alpha
+         char_alpha_numeric
+         char_alphanumeric
+         char_ascii
+         choose
+         double
+         double_STAR_
+         elements
+         fmap
+         frequency
+         generate
+         hash_map
+         int
+         keyword
+         keyword_ns
+         large_integer
+         large_integer_STAR_
+         let
+         list
+         list_distinct
+         list_distinct_by
+         map
+         nat
+         no_shrink
+         not_empty
+         one_of
+         recursive_gen
+         resize
+         return
+         sample
+         scale
+         set
+         shuffle
+         simple_type
+         simple_type_printable
+         sized
+         small_integer
+         string
+         string_alpha_numeric
+         string_alphanumeric
+         string_ascii
+         such_that
+         symbol
+         symbol_ns
+         tuple
+         uuid
+         vector
+         vector_distinct
+         vector_distinct_by}}

resources/cherry/clojure.test.check.properties.edn

@@ -0,0 +1 @@
+{:vars #{for_all_STAR_ ErrorResult}}

src/cherry/compiler.cljc

@@ -18,6 +18,7 @@
    [cherry.internal.loop :as loop]
    [cherry.internal.macros :as macros]
    [cherry.internal.protocols :as protocols]
+   [cherry.internal.test-check :as test-check]
    [squint.internal.test :as test]
    [squint.internal.macros :as squint-macros]
    [clojure.string :as str]
@@ -112,7 +113,15 @@
                             cc/common-macros))
 
 (def built-in-macro-nss
-  {'cherry.test test/core-test-macros})
+  {'cherry.test test/core-test-macros
+   'clojure.test.check.clojure-test test-check/clojure-test-macros
+   'clojure.test.check.properties test-check/properties-macros})
+
+(def cherry-extra-ns-mappings
+  '{clojure.test.check               "cherry-cljs/lib/clojure.test.check.js"
+    clojure.test.check.generators    "cherry-cljs/lib/clojure.test.check.js"
+    clojure.test.check.properties    "cherry-cljs/lib/clojure.test.check.js"
+    clojure.test.check.clojure-test  "cherry-cljs/lib/clojure.test.check.js"})
 
 (def core-config (resource/edn-resource "cherry/cljs.core.edn"))
 
@@ -437,7 +446,8 @@
                                                                 :imports imports
                                                                 :jsx false
                                                                 :need-html-import need-html-import
-                                                                :pragmas pragmas))
+                                                                :pragmas pragmas
+                                                                :built-in-macro-nss built-in-macro-nss))
                  jsx *jsx*
                  _ (when (and jsx jsx-runtime)
                      (swap! imports str

src/cherry/internal/cli.cljs

@@ -20,20 +20,21 @@
     file))
 
 (defn resolve-ns [opts in-file x]
-  (let [output-dir (:output-dir opts)
-        paths (:paths opts)
-        in-file-in-output-dir (file-in-output-dir in-file paths output-dir)]
-    (when-let [resolved
-               (some-> (utils/resolve-file x)
-                       (file-in-output-dir paths output-dir)
-                       (some->> (path/relative (path/dirname (str in-file-in-output-dir)))))]
-      (let [ext (:extension opts ".mjs")
-            ext (if (str/starts-with? ext ".")
-                  ext
-                  (str "." ext))
-            ext' (path/extname resolved)
-            file (str "./" (str/replace resolved (re-pattern (str ext' "$")) ext))]
-        file))))
+  (or (cc/cherry-extra-ns-mappings x)
+      (let [output-dir (:output-dir opts)
+            paths (:paths opts)
+            in-file-in-output-dir (file-in-output-dir in-file paths output-dir)]
+        (when-let [resolved
+                   (some-> (utils/resolve-file x)
+                           (file-in-output-dir paths output-dir)
+                           (some->> (path/relative (path/dirname (str in-file-in-output-dir)))))]
+          (let [ext (:extension opts ".mjs")
+                ext (if (str/starts-with? ext ".")
+                      ext
+                      (str "." ext))
+                ext' (path/extname resolved)
+                file (str "./" (str/replace resolved (re-pattern (str ext' "$")) ext))]
+            file)))))
 
 (defn files-from-path [path]
   (let [files (fs/readdirSync path)]

src/cherry/internal/test_check.cljc

@@ -0,0 +1,36 @@
+(ns cherry.internal.test-check)
+
+(defn core-defspec [_&form _&env name num-tests-or-prop & rest]
+  (let [[num-tests prop] (if (number? num-tests-or-prop)
+                           [num-tests-or-prop (first rest)]
+                           [100 num-tests-or-prop])]
+    `(def ~(vary-meta name assoc :test true)
+       (with-meta
+         (fn []
+           (let [result# (clojure.test.check/quick-check ~num-tests ~prop)]
+             (if (:pass? result#)
+               (clojure.test/report {:type :pass
+                                     :message (str "Passed " ~num-tests " trials")})
+               (clojure.test/report {:type :fail
+                                     :message (str "Failed after " (:num-tests result#) " trials")
+                                     :expected '~prop
+                                     :actual (:shrunk result#)}))))
+         {:name '~name}))))
+
+(defn- binding-vars [bindings]
+  (map first (partition 2 bindings)))
+
+(defn- binding-gens [bindings]
+  (map second (partition 2 bindings)))
+
+(defn core-for-all [_&form _&env bindings & body]
+  `(clojure.test.check.properties/for-all*
+    ~(vec (binding-gens bindings))
+    (fn [~@(binding-vars bindings)]
+      ~@body)))
+
+(def clojure-test-macros
+  {'defspec core-defspec})
+
+(def properties-macros
+  {'for-all core-for-all})

test/cherry/cross_platform_test.cljc

@@ -1,7 +1,10 @@
 (ns cherry.cross-platform-test
-  (:require [clojure.test :as t #?@(:clj [:refer [deftest is testing are]])]
-            [clojure.string :as str])
-  #?(:cljs (:require-macros [clojure.test :as t :refer [deftest is testing are async]])))
+  (:require [clojure.test :as t :refer [deftest is testing are
+                                        #?@(:cljs [async])]]
+            [clojure.string :as str]
+            [clojure.test.check.generators :as gen]
+            [clojure.test.check.clojure-test :as tc-test :refer [defspec]]
+            [clojure.test.check.properties :as prop]))
 
 (defonce test-db (atom nil))
 
@@ -398,6 +401,91 @@
                "run-tests should chain async tests in order")
            (t/set-once-fixtures! saved-fixtures))))))
 
+(defspec simple-integer-property 100
+  (prop/for-all [x gen/small-integer]
+                (= x x)))
+
+(defspec vector-reversal-property 50
+  (prop/for-all [v (gen/vector gen/small-integer)]
+                (= v (reverse (reverse v)))))
+
+(defspec generator-composition 50
+  (prop/for-all [x (gen/fmap inc gen/small-integer)]
+                (> x (- x 1))))
+
+(defspec multiple-generators 50
+  (prop/for-all [x gen/small-integer
+                 y gen/small-integer]
+                (= (+ x y) (+ y x))))
+
+(defspec string-concatenation 50
+  (prop/for-all [s1 gen/string-ascii
+                 s2 gen/string-ascii]
+                (= (count (str s1 s2))
+                   (+ (count s1) (count s2)))))
+
+(defspec map-property 50
+  (prop/for-all [m (gen/map gen/keyword gen/small-integer)]
+                (= (count m) (count (keys m)))))
+
+(defspec set-property 50
+  (prop/for-all [s (gen/set gen/small-integer)]
+                (<= (count s) 100)))
+
+(defspec such-that-property 50
+  (prop/for-all [x (gen/such-that pos? gen/small-integer 100)]
+                (pos? x)))
+
+(defspec pos-int-property 50
+  (prop/for-all [x (gen/large-integer* {:min 1})]
+                (pos? x)))
+
+(defspec neg-int-property 50
+  (prop/for-all [x (gen/large-integer* {:max -1})]
+                (neg? x)))
+
+(defspec nat-property 50
+  (prop/for-all [x gen/nat]
+                (nat-int? x)))
+
+(defspec list-distinct-property 50
+  (prop/for-all [xs (gen/list-distinct gen/small-integer)]
+                (= (count xs) (count (set xs)))))
+
+(defspec recursive-gen-property 20
+  (prop/for-all [tree (gen/recursive-gen
+                       (fn [inner] (gen/vector inner 0 3))
+                       gen/small-integer)]
+                (or (number? tree) (vector? tree))))
+
+(defspec resize-property 50
+  (prop/for-all [v (gen/resize 5 (gen/vector gen/small-integer))]
+                (<= (count v) 10)))
+
+#?(:cljs
+   (defspec verify-quick-check-catches-failures 20
+     (prop/for-all [x gen/small-integer]
+                   (pos? x))))
+
+#?(:cljs
+   (defn verify-failure-detection
+     "Runs verify-quick-check-catches-failures and asserts it catches the bug."
+     []
+     (let [saved-env (t/get-current-env)
+           saved-counters (:report-counters saved-env)]
+       (t/set-env! (assoc (t/empty-env) :testing-vars (:testing-vars saved-env)))
+       (let [fail-before (get-in (t/get-current-env) [:report-counters :fail] 0)]
+         (t/test-var verify-quick-check-catches-failures)
+         (let [fail-after (get-in (t/get-current-env) [:report-counters :fail] 0)]
+           (t/set-env! (assoc saved-env :report-counters saved-counters))
+           (when-not (> fail-after fail-before)
+             (throw (js/Error. "quick-check should have caught failure but didn't!"))))))))
+
+#?(:cljs
+   (defn test-clojure-test-vars []
+     (assert (number? tc-test/*default-test-count*)
+             "*default-test-count* should be a number")))
+
 #?(:clj
    (defn -main []
      (let [result (t/run-tests 'cherry.cross-platform-test)]
@@ -431,6 +519,22 @@
      (t/test-var report-only-counts-pass-fail-error-test)
      (await (t/test-var async-done-form-test))
      (t/test-var run-tests-quoted-symbol-test)
+     (t/test-var simple-integer-property)
+     (t/test-var vector-reversal-property)
+     (t/test-var generator-composition)
+     (t/test-var multiple-generators)
+     (t/test-var string-concatenation)
+     (t/test-var map-property)
+     (t/test-var set-property)
+     (t/test-var such-that-property)
+     (t/test-var pos-int-property)
+     (t/test-var neg-int-property)
+     (t/test-var nat-property)
+     (t/test-var list-distinct-property)
+     (t/test-var recursive-gen-property)
+     (t/test-var resize-property)
+     (test-clojure-test-vars)
+     (verify-failure-detection)
      (t/report {:type :summary})
      (let [results (:report-counters (t/get-current-env))]
        (when-not (t/successful? results)