├── deps.edn ├── doc └── intro.md ├── src ├── test │ └── clojure │ │ └── clojure │ │ └── test │ │ └── check │ │ ├── test.cljc │ │ ├── results_test.cljc │ │ ├── rose_tree_test.cljc │ │ ├── test_specs.clj │ │ ├── random_test.clj │ │ └── clojure_test_test.cljc └── main │ ├── clojure │ └── clojure │ │ └── test │ │ ├── check │ │ ├── generators.cljc │ │ ├── impl.cljc │ │ ├── clojure_test │ │ │ ├── cljs.cljc │ │ │ └── assertions.cljc │ │ ├── results.cljc │ │ ├── properties.cljc │ │ ├── rose_tree.cljc │ │ ├── random.clj │ │ └── clojure_test.cljc │ │ └── check.cljc │ └── dotnet │ └── packager │ ├── clojure.test.check.csproj │ └── clojure.test.check.sln ├── .gitignore ├── CONTRIBUTING.md ├── README.md └── project.clj /deps.edn: -------------------------------------------------------------------------------- 1 | { 2 | :deps {} 3 | :paths ["src/main/clojure"] 4 | } -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | # Introduction to clr.test.check 2 | 3 | TODO: write [great documentation](http://jacobian.org/writing/great-documentation/what-to-write/) -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/test.cljc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure/clr.test.check/master/src/test/clojure/clojure/test/check/test.cljc -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/generators.cljc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure/clr.test.check/master/src/main/clojure/clojure/test/check/generators.cljc -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | pom.xml 2 | /lib/ 3 | /classes/ 4 | /targets/ 5 | /target 6 | /classes 7 | /checkouts 8 | *.jar 9 | *.class 10 | *.dll 11 | *.pdb 12 | *.exe 13 | .lein-deps-sum 14 | .lein-failures 15 | .lein-plugins 16 | .vs 17 | 18 | #Visual Studio artifacts 19 | bin 20 | obj 21 | *.user 22 | *.suo 23 | *.nupkg 24 | 25 | .cpcache -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This is a [Clojure contrib] project. 2 | 3 | Under the Clojure contrib [guidelines], this project cannot accept 4 | pull requests. All patches must be submitted via [JIRA]. 5 | 6 | See [Contributing] on the Clojure website for 7 | more information on how to contribute. 8 | 9 | [Clojure contrib]: https://clojure.org/community/contrib_libs 10 | [Contributing]: https://clojure.org/community/contributing 11 | [JIRA]: https://clojure.atlassian.net/browse/TNS 12 | [guidelines]: https://clojure.org/community/contrib_howto -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/impl.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.impl) 11 | 12 | (defn get-current-time-millis [] 13 | #?(:clj (System/currentTimeMillis) 14 | :cljr (Environment/TickCount) ;;; Added :cljr clause 15 | :cljs (.valueOf (js/Date.)))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/clojure_test/cljs.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey and contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.test.check.clojure-test.assertions.cljs) 10 | 11 | #?(:default ;;; change :clj to :default 12 | (try 13 | (require 'cljs.test 14 | '[clojure.test.check.clojure-test.assertions :as assertions]) 15 | 16 | (eval 17 | '(defmethod cljs.test/assert-expr 'clojure.test.check.clojure-test/check? 18 | [_ msg form] 19 | (assertions/check? msg form))) 20 | (catch java.io.FileNotFoundException e))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/results.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns ^{:author "Gary Fredericks" 11 | :doc "A protocol and helper functions for trial results."} 12 | clojure.test.check.results) 13 | 14 | (defprotocol Result 15 | (pass? [result] "A boolean indicating if the result passed.") 16 | (result-data [result] "A map of data about the trial.")) 17 | 18 | (extend-protocol Result 19 | #?(:clj Object :cljs default :cljr Object) ;;; Added :cljr k/v 20 | (pass? [this] (boolean this)) 21 | (result-data [this] nil) 22 | 23 | nil 24 | (pass? [this] false) 25 | (result-data [this] nil)) -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.test.check.csproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | netstandard2.0;netstandard2.1 5 | 6 | 7 | 8 | clojure.test.check 9 | clojure.test 10 | clojure.test.check 11 | clojure.tools.namespace 12 | clojure.test.check 13 | ClojureCLR contributors 14 | Property-based testing of Clojure code 15 | Copyright © Rich Hickey, ClojureCLR contributors 2024 16 | EPL-1.0 17 | https://github.com/clojure/clr.test.check 18 | ClojureCLR contributors 19 | Clojure;ClojureCLR 20 | 1.1.2 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/results_test.cljc: -------------------------------------------------------------------------------- 1 | ; All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.test.check.results-test 10 | (:require #?(:cljs 11 | [cljs.test :as test :refer-macros [are deftest testing is]]) 12 | #?(:default ;;; changed :clj to :default 13 | [clojure.test :refer :all]) 14 | [clojure.test.check.results :as results])) 15 | 16 | (deftest default-passing-values 17 | (is (not (results/pass? nil))) 18 | (is (not (results/pass? false))) 19 | (are [x] (results/pass? x) 20 | :keyword 21 | 'symbol 22 | "string" 23 | [] 24 | {} 25 | #{} 26 | () 27 | 42 28 | 42.0 29 | true)) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # clr.test.check 2 | 3 | A port of [clojure/test/check](https://github.com/clojure/test.check) library to ClojureCLR. 4 | 5 | From the original's README: 6 | 7 | > _test.check_ is a Clojure property-based testing tool inspired by QuickCheck. The core idea of _test.check_ is that instead of enumerating expected input and output for unit tests, you write properties about your function that should hold true for all inputs. This lets you write concise, powerful tests 8 | 9 | ## Releases 10 | 11 | [clj/deps.edn](https://clojure.org/guides/deps_edn) dependency information: 12 | ```clojure 13 | io.github.clojure/clr.test.check {:git/tag "v1.1.2" :git/sha "26f34e6"} 14 | ``` 15 | 16 | Nuget reference: 17 | 18 | ``` 19 | Install-Package clojure.test.check -Version 1.1.2 20 | ``` 21 | 22 | Leiningen/Clojars reference: 23 | 24 | ``` 25 | [org.clojure.clr/test.check "1.1.2"] 26 | ``` 27 | 28 | 29 | ## Contributing 30 | 31 | We can not accept pull requests. Please see [CONTRIBUTING.md](CONTRIBUTING.md) 32 | for details. 33 | 34 | 35 | ## License 36 | 37 | Original: 38 | 39 | > Copyright © Rich Hickey, Reid Draper and contributors 40 | 41 | Distributed under the Eclipse Public License, the same as Clojure. -------------------------------------------------------------------------------- /src/main/dotnet/packager/clojure.test.check.sln: -------------------------------------------------------------------------------- 1 | 2 | Microsoft Visual Studio Solution File, Format Version 12.00 3 | # Visual Studio Version 17 4 | VisualStudioVersion = 17.8.34601.278 5 | MinimumVisualStudioVersion = 10.0.40219.1 6 | Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "clojure.test.check", "clojure.test.check.csproj", "{ADFB94B9-DCFF-4DFA-AD47-438E1AD2C49E}" 7 | EndProject 8 | Global 9 | GlobalSection(SolutionConfigurationPlatforms) = preSolution 10 | Debug|Any CPU = Debug|Any CPU 11 | Release|Any CPU = Release|Any CPU 12 | EndGlobalSection 13 | GlobalSection(ProjectConfigurationPlatforms) = postSolution 14 | {ADFB94B9-DCFF-4DFA-AD47-438E1AD2C49E}.Debug|Any CPU.ActiveCfg = Debug|Any CPU 15 | {ADFB94B9-DCFF-4DFA-AD47-438E1AD2C49E}.Debug|Any CPU.Build.0 = Debug|Any CPU 16 | {ADFB94B9-DCFF-4DFA-AD47-438E1AD2C49E}.Release|Any CPU.ActiveCfg = Release|Any CPU 17 | {ADFB94B9-DCFF-4DFA-AD47-438E1AD2C49E}.Release|Any CPU.Build.0 = Release|Any CPU 18 | EndGlobalSection 19 | GlobalSection(SolutionProperties) = preSolution 20 | HideSolutionNode = FALSE 21 | EndGlobalSection 22 | GlobalSection(ExtensibilityGlobals) = postSolution 23 | SolutionGuid = {E6127C26-305D-45F6-98E1-6117D55A42C4} 24 | EndGlobalSection 25 | EndGlobal 26 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/rose_tree_test.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.rose-tree-test 11 | (:require [clojure.test.check.generators :as gen] 12 | [clojure.test.check.properties :as prop] 13 | [clojure.test.check.rose-tree :as rose] 14 | [clojure.test.check.clojure-test :as ct :refer [defspec]])) 15 | 16 | (defn depth-one-children 17 | [rose] 18 | (into [] (map rose/root (rose/children rose)))) 19 | 20 | (defn depth-one-and-two-children 21 | [rose] 22 | (let [the-children (rose/children rose)] 23 | (into [] 24 | (concat 25 | (map rose/root the-children) 26 | (map rose/root (mapcat rose/children the-children)))))) 27 | 28 | (defspec test-collapse-rose 29 | 100 30 | (prop/for-all [i gen/small-integer] 31 | (let [tree (#'gen/int-rose-tree i)] 32 | (= (depth-one-and-two-children tree) 33 | (depth-one-children (rose/collapse tree)))))) -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject org.clojure.clr/test.check "1.1.2" 2 | :description "Port of github.com/clojure/test.check to ClojureCLR" 3 | :url "https://github.com/clojure/clr.test.check" 4 | :license {:name "Eclipse Public License" 5 | :url "http://www.eclipse.org/legal/epl-v10.html"} 6 | :dependencies [] 7 | :source-paths ["src/main/clojure"] 8 | :test-paths ["src/test/clojure"] 9 | :warn-on-reflection true 10 | :min-lein-version "2.0.0" 11 | :plugins [[lein-clr "0.2.1"]] 12 | :deploy-repositories [["clojars" {:url "https://clojars.org/repo/" 13 | :sign-releases false}]] 14 | :clr {:cmd-templates {:clj-exe [#_"mono" [CLJCLR15_40 %1]] 15 | :clj-dep [#_"mono" ["target/clr/clj/Debug 4.0" %1]] 16 | :clj-url "https://github.com/downloads/clojure/clojure-clr/clojure-clr-1.4.0-Debug-4.0.zip" 17 | :clj-zip "clojure-clr-1.4.0-Debug-4.0.zip" 18 | :curl ["curl" "--insecure" "-f" "-L" "-o" %1 %2] 19 | :nuget-ver [#_"mono" [*PATH "nuget.exe"] "install" %1 "-Version" %2] 20 | :nuget-any [#_"mono" [*PATH "nuget.exe"] "install" %1] 21 | :unzip ["unzip" "-d" %1 %2] 22 | :wget ["wget" "--no-check-certificate" "--no-clobber" "-O" %1 %2]} 23 | ;; for automatic download/unzip of ClojureCLR, 24 | ;; 1. make sure you have curl or wget installed and on PATH, 25 | ;; 2. uncomment deps in :deps-cmds, and 26 | ;; 3. use :clj-dep instead of :clj-exe in :main-cmd and :compile-cmd 27 | :deps-cmds [; [:wget :clj-zip :clj-url] ; edit to use :curl instead of :wget 28 | ; [:unzip "../clj" :clj-zip] 29 | ] 30 | :main-cmd [:clj-exe "Clojure.Main.exe"] 31 | :compile-cmd [:clj-exe "Clojure.Compile.exe"]}) -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/test_specs.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.test.check.test-specs 2 | ) 3 | 4 | (if (let [{:keys [major minor]} *clojure-version*] 5 | (and (= 1 major) (< minor 9))) 6 | ;; don't bother testing this on older clojures 7 | (def valid-reporter-fn-call? (constantly true)) 8 | 9 | (do 10 | (require '[clojure.spec.alpha :as s]) 11 | (eval 12 | '(do 13 | 14 | (s/def ::base 15 | (s/keys :req-un [::type ::seed ::num-tests 16 | ::property])) 17 | 18 | (defmulti type->spec :type) 19 | 20 | (defmethod type->spec :trial 21 | [_] 22 | (s/merge ::base 23 | (s/keys :req-un [::args 24 | ::result 25 | ::result-data]))) 26 | 27 | (defmethod type->spec :failure 28 | [_] 29 | (s/merge ::base 30 | (s/keys :req-un [::fail 31 | ::failing-size 32 | ::result 33 | ::result-data]))) 34 | 35 | (s/def ::shrunk 36 | (s/keys :req-un [::depth ::result ::result-data ::smallest ::total-nodes-visited])) 37 | 38 | (s/def ::shrinking 39 | (s/merge ::shrunk (s/keys :req-un [::args]))) 40 | 41 | (defmethod type->spec :shrink-step 42 | [_] 43 | (s/merge ::base 44 | (s/keys :req-un [::fail 45 | ::failing-size 46 | ::result 47 | ::result-data 48 | ::shrinking]))) 49 | 50 | (defmethod type->spec :shrunk 51 | [_] 52 | (s/merge ::base 53 | (s/keys :req-un [::fail 54 | ::failing-size 55 | ::result 56 | ::result-data 57 | ::shrunk]))) 58 | 59 | (defmethod type->spec :complete 60 | [_] 61 | (s/merge ::base 62 | (s/keys :req-un [::result]))) 63 | 64 | (s/def ::value (s/multi-spec type->spec :type)) 65 | 66 | (defn valid-reporter-fn-call? 67 | [m] 68 | (or 69 | (s/valid? ::value m) 70 | (s/explain ::value m))))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/clojure_test/assertions.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey and contributors. All rights reserved. 2 | ; The use and distribution terms for this software are covered by the 3 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ; which can be found in the file epl-v10.html at the root of this distribution. 5 | ; By using this software in any fashion, you are agreeing to be bound by 6 | ; the terms of this license. 7 | ; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.test.check.clojure-test.assertions 10 | #?(:cljs (:require-macros [clojure.test.check.clojure-test.assertions.cljs])) 11 | (:require #?(:default [clojure.test :as t] ;;; changed :clj to :default 12 | :cljs [cljs.test :as t]))) 13 | 14 | #?(:cljr ;;; changed :clj to :cljr 15 | (defn test-context-stacktrace [st] 16 | (drop-while 17 | #(let [class-name (.FullName (.GetType ^System.Diagnostics.StackFrame %))] ;;; (.getClassName ^StackTraceElement %) 18 | (or (.StartsWith class-name "System") ;;; .startsWith "java.lang" -- I guess "System" as good as I can get 19 | (.StartsWith class-name "clojure.test+") ;;; .startsWith "clojure.test$" 20 | (.StartsWith class-name "clojure.test.check.clojure_test+") ;;; .startsWith "clojure.test.check.clojure_test$" 21 | (.StartsWith class-name "clojure.test.check.clojure_test.assertions"))) ;;; .startsWith 22 | st))) 23 | 24 | #?(:cljr ;;; changed :clj to :cljr 25 | (defn file-and-line* 26 | [stacktrace] 27 | (if (seq stacktrace) 28 | (let [^System.Diagnostics.StackFrame s (first stacktrace)] ;;; ^StackTraceElement 29 | {:file (.GetFileName s) :line (.GetFileLineNumber s)}) ;;; .getFileName .getLineNumber 30 | {:file nil :line nil}))) 31 | 32 | (defn check-results [m] 33 | (if (:pass? m) 34 | (t/do-report 35 | {:type :pass 36 | :message (dissoc m :result)}) 37 | (t/do-report 38 | (merge {:type :fail 39 | :expected {:result true} 40 | :actual m} 41 | #?(:clj (file-and-line* (test-context-stacktrace (.getStackTrace (Thread/currentThread)))) 42 | :cljr (file-and-line* (test-context-stacktrace (.GetFrames (System.Diagnostics.StackTrace.)))) ;;; Added :cljr 43 | :cljs (t/file-and-line (js/Error.) 4)))))) 44 | 45 | (defn check? 46 | [_ form] 47 | `(let [m# ~(nth form 1)] 48 | (check-results m#))) 49 | 50 | 51 | #?(:default ;;; changed :clj to :default 52 | (defmethod t/assert-expr 'clojure.test.check.clojure-test/check? 53 | [_ form] 54 | (check? _ form)) 55 | :cljs 56 | (when (exists? js/cljs.test$macros) 57 | (defmethod js/cljs.test$macros.assert_expr 'clojure.test.check.clojure-test/check? 58 | [_ msg form] 59 | (clojure.test.check.clojure-test.assertions/check? msg form)))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/properties.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.properties 11 | (:require [clojure.test.check.generators :as gen] 12 | [clojure.test.check.results :as results]) 13 | #?(:cljs (:require-macros [clojure.test.check.properties :refer [for-all]]))) 14 | 15 | (defrecord ErrorResult [error] 16 | results/Result 17 | (pass? [_] false) 18 | (result-data [_] 19 | ;; spelling out the whole keyword here since `::error` is 20 | ;; different in self-hosted cljs. 21 | {:clojure.test.check.properties/error error})) 22 | 23 | (defn ^:private exception? 24 | [x] 25 | (instance? #?(:clj Throwable :cljs js/Error :cljr Exception) x)) ;;; Added :cljr clause 26 | 27 | (defn ^:private apply-gen 28 | [function] 29 | (fn [args] 30 | (let [result (try 31 | (let [ret (apply function args)] 32 | ;; TCHECK-131: for backwards compatibility (mainly 33 | ;; for spec), treat returned exceptions like thrown 34 | ;; exceptions 35 | (if (exception? ret) 36 | (throw ret) 37 | ret)) 38 | #?(:clj (catch java.lang.ThreadDeath t (throw t))) 39 | (catch #?(:clj Throwable :cljs :default :cljr Exception) ex ;;; Added :cljr clause 40 | (->ErrorResult ex)))] 41 | {:result result 42 | :function function 43 | :args args}))) 44 | 45 | (defn for-all* 46 | "A function version of `for-all`. Takes a sequence of N generators 47 | and a function of N args, and returns a property that calls the 48 | function with generated values and tests the return value for 49 | truthiness, like with `for-all`. 50 | 51 | Example: 52 | 53 | (for-all* [gen/large-integer gen/large-integer] 54 | (fn [a b] (>= (+ a b) a)))" 55 | [args function] 56 | (gen/fmap 57 | (apply-gen function) 58 | (apply gen/tuple args))) 59 | 60 | (defn- binding-vars 61 | [bindings] 62 | (map first (partition 2 bindings))) 63 | 64 | (defn- binding-gens 65 | [bindings] 66 | (map second (partition 2 bindings))) 67 | 68 | (defmacro for-all 69 | "Returns a property, which is the combination of some generators and 70 | an assertion that should be true for all generated values. Properties 71 | can be used with `quick-check` or `defspec`. 72 | 73 | `for-all` takes a `let`-style bindings vector, where the right-hand 74 | side of each binding is a generator. 75 | 76 | The body should be an expression of the generated values that will 77 | be tested for truthiness, unless it is a special implementation of 78 | the clojure.test.check.results/Result protocol. Exceptions in the 79 | body will be caught and treated as failures. 80 | 81 | When there are multiple binding pairs, the earlier pairs are not 82 | visible to the later pairs. 83 | If there are multiple body expressions, all but the last one are 84 | executed for side effects, as with `do`. 85 | Example: 86 | (for-all [a gen/large-integer 87 | b gen/large-integer] 88 | (>= (+ a b) a))" 89 | [bindings & body] 90 | `(for-all* ~(vec (binding-gens bindings)) 91 | (fn [~@(binding-vars bindings)] 92 | ~@body))) -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/random_test.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.test.check.random-test 2 | "Tests of the custom RNG. This is a little weird since the subject 3 | of the tests (the random number generator) is also the primary 4 | internal driver of the tests, but hopefully it will still be 5 | meaningful." 6 | (:require [clojure.test.check.clojure-test :refer [defspec]] 7 | [clojure.test.check.generators :as gen] 8 | [clojure.test.check.properties :as prop] 9 | [clojure.test.check.random :as random])) 10 | 11 | (def gen-split-steps 12 | (gen/list (gen/elements [:left :right]))) 13 | 14 | (defn apply-split-steps 15 | [rng steps] 16 | (reduce (fn [rng step] 17 | (let [[rng1 rng2] (random/split rng)] 18 | (case step :left rng1 :right rng2))) 19 | rng 20 | steps)) 21 | 22 | (def gen-seed 23 | (let [gen-int (gen/choose 0 Int32/MaxValue)] ;;; Integer/MAX_VALUE 24 | (gen/fmap (fn [[s1 s2]] 25 | (bit-or s1 (bit-shift-left s2 32))) 26 | (gen/tuple gen-int gen-int)))) 27 | 28 | (defspec determinism-spec 29 | (prop/for-all [seed gen-seed 30 | steps gen-split-steps] 31 | (let [r1 (random/make-random seed) 32 | r2 (random/make-random seed)] 33 | (= (-> r1 (apply-split-steps steps) (random/rand-long)) 34 | (-> r2 (apply-split-steps steps) (random/rand-long)))))) 35 | 36 | (defn get-256-longs 37 | [rng] 38 | (map random/rand-long 39 | (nth (iterate #(mapcat random/split %) [rng]) 8))) 40 | 41 | ;; this spec is only statistically certain to pass, not logically 42 | ;; certain. The probability of a false failure (1/2^16384 or so) is 43 | ;; low enough to ignore. 44 | (defspec different-states-spec 45 | (prop/for-all [seed gen-seed 46 | pre-steps gen-split-steps 47 | post-steps-1 gen-split-steps 48 | post-steps-2 gen-split-steps] 49 | (let [r (random/make-random seed) 50 | r' (apply-split-steps r pre-steps) 51 | [r1 r2] (random/split r') 52 | r1' (apply-split-steps r1 post-steps-1) 53 | r2' (apply-split-steps r2 post-steps-2)] 54 | ;; r1' and r2' should not somehow be in the same state 55 | (not= (get-256-longs r1') 56 | (get-256-longs r2'))))) 57 | 58 | ;; Tests of the particular JavaUtilSplittableRandom impl, by 59 | ;; comparing with java.util.SplittableRandom on Java 8 60 | #_(when (try (Class/forName "java.util.SplittableRandom") -- commented out -- evey Class/forName won't work for us 61 | (catch ClassNotFoundException e)) 62 | (eval 63 | '(defspec java-util-splittable-random-spec 64 | (prop/for-all [seed gen-seed 65 | steps gen-split-steps] 66 | (let [immutable-rng (apply-split-steps 67 | (random/make-java-util-splittable-random seed) 68 | steps) 69 | mutable-rng 70 | ^java.util.SplittableRandom 71 | (reduce (fn [^java.util.SplittableRandom rng step] 72 | (let [rng2 (.split rng)] 73 | (case step :left rng :right rng2))) 74 | (java.util.SplittableRandom. seed) 75 | steps)] 76 | (= (random/rand-long immutable-rng) 77 | (.nextLong mutable-rng)))))) 78 | 79 | ;; same test but for rand-double 80 | (eval 81 | '(defspec java-util-splittable-random-spec-double 82 | (prop/for-all [seed gen-seed 83 | steps gen-split-steps] 84 | (let [immutable-rng (apply-split-steps 85 | (random/make-java-util-splittable-random seed) 86 | steps) 87 | mutable-rng 88 | ^java.util.SplittableRandom 89 | (reduce (fn [^java.util.SplittableRandom rng step] 90 | (let [rng2 (.split rng)] 91 | (case step :left rng :right rng2))) 92 | (java.util.SplittableRandom. seed) 93 | steps)] 94 | (= (random/rand-double immutable-rng) 95 | (.nextDouble mutable-rng))))))) 96 | 97 | (defspec split-n-spec 40 98 | (prop/for-all [seed gen-seed 99 | n gen/nat] 100 | (let [rng (random/make-random seed)] 101 | ;; checking that split-n returns the same generators that we 102 | ;; would get by doing a particular series of splits manually 103 | (= (map random/rand-long (random/split-n rng n)) 104 | (map random/rand-long 105 | (if (zero? n) 106 | [] 107 | (loop [v [], rng rng] 108 | (if (= (dec n) (count v)) 109 | (conj v rng) 110 | (let [[rng1 rng2] (random/split rng)] 111 | (recur (conj v rng2) rng1)))))))))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/rose_tree.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.rose-tree 11 | "A lazy tree data structure used for shrinking." 12 | (:refer-clojure :exclude [filter remove seq]) 13 | (:require [#?(:default clojure.core :cljs cljs.core) :as core])) ;;; Changed :clj to :default 14 | 15 | (deftype RoseTree [root children] 16 | #?(:default clojure.lang.Indexed ;;; Changed :clj to :default 17 | :cljs IIndexed) 18 | (#?(:default nth :cljs -nth) [this i] ;;; Changed :clj to :default 19 | (cond (= i 0) root 20 | (= i 1) children 21 | :else (throw #?(:clj (IndexOutOfBoundsException.) :cljr (IndexOutOfRangeException.) ;;; Added :cljr clause 22 | :cljs (js/Error. "Index out of bounds in rose tree"))))) 23 | 24 | (#?(:default nth :cljs -nth) [this i not-found] ;;; Changed :clj to :default 25 | (cond (= i 0) root 26 | (= i 1) children 27 | :else not-found))) 28 | 29 | (defn root 30 | "Returns the root of a Rose tree." 31 | {:no-doc true} 32 | [^RoseTree rose] 33 | (.-root rose)) 34 | 35 | (defn children 36 | "Returns the children of the root of the Rose tree." 37 | {:no-doc true} 38 | [^RoseTree rose] 39 | (.-children rose)) 40 | 41 | (defn make-rose 42 | [root children] 43 | (RoseTree. root children)) 44 | 45 | (defn- exclude-nth 46 | "Exclude the nth value in a collection." 47 | [n coll] 48 | (lazy-seq 49 | (when-let [s (core/seq coll)] 50 | (if (zero? n) 51 | (rest coll) 52 | (cons (first s) 53 | (exclude-nth (dec n) (rest s))))))) 54 | 55 | (defn join 56 | "Turn a tree of trees into a single tree. Does this by concatenating 57 | children of the inner and outer trees." 58 | {:no-doc true} 59 | [rose] 60 | (let [outer-root (root rose) 61 | outer-children (children rose) 62 | inner-root (root outer-root) 63 | inner-children (children outer-root)] 64 | (make-rose inner-root (concat (map join outer-children) 65 | inner-children)))) 66 | 67 | (defn pure 68 | "Puts a value `x` into a Rose tree, with no children." 69 | {:no-doc true} 70 | [x] 71 | (make-rose x [])) 72 | 73 | (defn fmap 74 | "Applies functions `f` to all values in the tree." 75 | {:no-doc true} 76 | [f rose] 77 | (make-rose (f (root rose)) (map #(fmap f %) (children rose)))) 78 | 79 | (defn bind 80 | "Takes a Rose tree (m) and a function (k) from 81 | values to Rose tree and returns a new Rose tree. 82 | This is the monadic bind (>>=) for Rose trees." 83 | {:no-doc true} 84 | [m k] 85 | (join (fmap k m))) 86 | 87 | (defn filter 88 | "Returns a new Rose tree whose values pass `pred`. Values who 89 | do not pass `pred` have their children cut out as well." 90 | {:no-doc true} 91 | [pred rose] 92 | (make-rose (root rose) 93 | (map #(filter pred %) 94 | (core/filter #(pred (root %)) (children rose))))) 95 | 96 | (defn permutations 97 | "Create a seq of vectors, where each rose in turn, has been replaced 98 | by its children." 99 | {:no-doc true} 100 | [roses] 101 | (for [[rose index] (map vector roses (range)) 102 | child (children rose)] 103 | (assoc roses index child))) 104 | 105 | (defn zip 106 | "Apply `f` to the sequence of Rose trees `roses`." 107 | {:no-doc true} 108 | [f roses] 109 | (make-rose 110 | (apply f (map root roses)) 111 | (map #(zip f %) 112 | (permutations roses)))) 113 | 114 | (defn remove 115 | {:no-doc true} 116 | [roses] 117 | (concat 118 | (map-indexed (fn [index _] (exclude-nth index roses)) roses) 119 | (permutations (vec roses)))) 120 | 121 | (defn ^:private unchunk 122 | "Returns an equivalent lazy seq that is not chunked." 123 | [a-lazy-seq] 124 | (take 125 | #?(:clj Double/POSITIVE_INFINITY :cljs js/Infinity :cljr Double/PositiveInfinity) ;;; Added :cljr clause 126 | a-lazy-seq)) 127 | 128 | (defn shrink 129 | {:no-doc true} 130 | [f roses] 131 | (if (core/seq roses) 132 | (make-rose (apply f (map root roses)) 133 | (map #(shrink f %) (remove (unchunk roses)))) 134 | (make-rose (f) []))) 135 | 136 | (declare shrink-vector*) 137 | 138 | (defn ^:private bifurcate 139 | "Returns a sequence of rose trees representing shrinks that discard 140 | half of the vector of roses." 141 | [f roses] 142 | (when (<= 4 (count roses)) 143 | (let [left-count (quot (count roses) 2)] 144 | (lazy-seq 145 | (cons 146 | (shrink-vector* f (subvec roses 0 left-count)) 147 | (lazy-seq 148 | (list (shrink-vector* f (subvec roses left-count))))))))) 149 | 150 | (defn ^:private shrink-vector* 151 | [f roses] 152 | (let [thing (shrink f roses)] 153 | (make-rose (root thing) 154 | (concat (bifurcate f roses) (children thing))))) 155 | 156 | (defn shrink-vector 157 | [f roses] 158 | {:pre [(vector? roses)]} 159 | (let [rose (shrink-vector* f roses) 160 | empty-rose (make-rose (f) [])] 161 | (if (empty? roses) 162 | rose 163 | (make-rose (root rose) 164 | (cons empty-rose (children rose)))))) 165 | 166 | (defn collapse 167 | "Return a new rose-tree whose depth-one children 168 | are the children from depth one _and_ two of the input 169 | tree." 170 | {:no-doc true} 171 | [rose] 172 | (make-rose (root rose) 173 | (let [the-children (children rose)] 174 | (concat (map collapse the-children) 175 | (map collapse 176 | (mapcat children the-children)))))) 177 | 178 | (defn- make-stack 179 | [children stack] 180 | (if-let [s (core/seq children)] 181 | (cons children stack) 182 | stack)) 183 | 184 | (defn seq 185 | "Create a lazy-seq of all of the (unique) nodes in a shrink-tree. 186 | This assumes that two nodes with the same value have the same children. 187 | While it's not common, it's possible to create trees that don't 188 | fit that description. This function is significantly faster than 189 | brute-force enumerating all of the nodes in a tree, as there will 190 | be many duplicates." 191 | [rose] 192 | (let [helper (fn helper [rose seen stack] 193 | (let [node (root rose) 194 | the-children (children rose)] 195 | (lazy-seq 196 | (if-not (seen node) 197 | (cons node 198 | (if (core/seq the-children) 199 | (helper (first the-children) (conj seen node) (make-stack (rest the-children) stack)) 200 | (when-let [s (core/seq stack)] 201 | (let [f (ffirst s) 202 | r (rest (first s))] 203 | (helper f (conj seen node) (make-stack r (rest s))))))) 204 | (when-let [s (core/seq stack)] 205 | (let [f (ffirst s) 206 | r (rest (first s))] 207 | (helper f seen (make-stack r (rest s)))))))))] 208 | (helper rose #{} '()))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/random.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns ^{:author "Gary Fredericks" 11 | :doc "Purely functional and splittable pseudo-random number generators."} 12 | clojure.test.check.random 13 | (:refer-clojure :exclude [unsigned-bit-shift-right])) 14 | 15 | (defprotocol IRandom 16 | (rand-long [rng] 17 | "Returns a random long based on the given immutable RNG. 18 | 19 | Note: to maintain independence you should not call more than one 20 | function in the IRandom protocol with the same argument") 21 | (rand-double [rng] 22 | "Returns a random double between zero (inclusive) and 1.0 (exclusive) 23 | based on the given immutable RNG. 24 | 25 | Note: to maintain independence you should not call split and rand-double 26 | with the same argument") 27 | (split [rng] 28 | "Returns two new RNGs [rng1 rng2], which should generate 29 | sufficiently independent random data. 30 | 31 | Note: to maintain independence you should not call more than one 32 | function in the IRandom protocol with the same argument") 33 | (split-n [rng n] 34 | "Returns a collection of `n` RNGs, which should generate 35 | sufficiently independent random data. 36 | 37 | Note: to maintain independence you should not call more than one 38 | function in the IRandom protocol with the same argument")) 39 | 40 | ;; Immutable version of Java 8's java.util.SplittableRandom 41 | ;; 42 | ;; Meant to give the same results as similar uses of 43 | ;; java.util.SplittableRandom, in particular: 44 | ;; 45 | ;; (= (-> (make-java-util-splittable-random 42) 46 | ;; (rand-long)) 47 | ;; (.nextLong (SplittableRandom. 42))) 48 | ;; 49 | ;; (= (-> (make-java-util-splittable-random 42) 50 | ;; (split) 51 | ;; (first) 52 | ;; (rand-long)) 53 | ;; (.nextLong (doto (SplittableRandom. 42) 54 | ;; (.split)))) 55 | ;; 56 | ;; (= (-> (make-java-util-splittable-random 42) 57 | ;; (split) 58 | ;; (second) 59 | ;; (rand-long)) 60 | ;; (.nextLong (.split (SplittableRandom. 42)))) 61 | ;; 62 | ;; Also see the spec that checks this equivalency. 63 | 64 | 65 | ;; backwards compatibility for clojure 1.5 66 | (def ^:private old-clojure? 67 | (not (resolve 'clojure.core/unsigned-bit-shift-right))) 68 | (defmacro ^:private unsigned-bit-shift-right 69 | [x n] 70 | {:pre [(<= 1 n 63)]} 71 | (if old-clojure? 72 | (let [mask (-> Int64/MinValue ;;; Long/MIN_VALUE 73 | (bit-shift-right (dec n)) 74 | ((fn [^long x] (bit-and-not x x))))] ;;; (bit-not) -- temporary fix, until I get bit-not working in clojure.core -- sigh 75 | `(-> ~x 76 | (bit-shift-right ~n) 77 | (bit-and ~mask))) 78 | `(clojure.core/unsigned-bit-shift-right ~x ~n))) 79 | 80 | (defmacro ^:private longify 81 | "Macro for writing arbitrary longs in the java 0x syntax. E.g. 82 | 0x9e3779b97f4a7c15 (which is read as a bigint because it's out 83 | of range) becomes -7046029254386353131." 84 | [num] 85 | (if (> num Int64/MinValue) ;;; Long/MIN_VALUE 86 | (-> num 87 | (- 18446744073709551616N) 88 | (long) 89 | (bit-or -9223372036854775808)) 90 | num)) 91 | 92 | (set! *unchecked-math* :warn-on-boxed) 93 | 94 | (defmacro ^:private bxoubsr 95 | "Performs (-> x (unsigned-bit-shift-right n) (bit-xor x))." 96 | [x n] 97 | (vary-meta 98 | `(let [x# ~x] 99 | (-> x# (unsigned-bit-shift-right ~n) (bit-xor x#))) 100 | assoc :tag 'long)) 101 | 102 | (defmacro ^:private mix-64 103 | [n] 104 | `(-> ~n 105 | (bxoubsr 30) 106 | (* (longify 0xbf58476d1ce4e5b9)) 107 | (bxoubsr 27) 108 | (* (longify 0x94d049bb133111eb)) 109 | (bxoubsr 31))) 110 | 111 | ;;; DM: Added -- if I ever add a bitCount for Int64 in the base Clojure code, we can get rid of this 112 | 113 | (defn long-bit-count ^long [^long i] 114 | (let [i (- i ^long (bit-and (unsigned-bit-shift-right i 1) 0x5555555555555555)) 115 | i (+ (bit-and i 0x3333333333333333) (bit-and (unsigned-bit-shift-right i 2) 0x3333333333333333)) 116 | i (bit-and (+ i (unsigned-bit-shift-right i 4)) 0x0f0f0f0f0f0f0f0f) 117 | i (+ i (unsigned-bit-shift-right i 8)) 118 | i (+ i (unsigned-bit-shift-right i 16)) 119 | i (+ i (unsigned-bit-shift-right i 32))] 120 | (long (bit-and (int i) (int 0x7f))))) 121 | 122 | ; public static int bitCount(long i) { 123 | ; // HD, Figure 5-14 124 | ; i = i - ((i >>> 1) & 0x5555555555555555L); 125 | ; i = (i & 0x3333333333333333L) + ((i >>> 2) & 0x3333333333333333L); 126 | ; i = (i + (i >>> 4)) & 0x0f0f0f0f0f0f0f0fL; 127 | ; i = i + (i >>> 8); 128 | ; i = i + (i >>> 16); 129 | ; i = i + (i >>> 32); 130 | ; return (int)i & 0x7f; 131 | ; } 132 | ; 133 | ;;; 134 | 135 | (defmacro ^:private mix-gamma 136 | [n] 137 | `(-> ~n 138 | (bxoubsr 33) 139 | (* (longify 0xff51afd7ed558ccd)) 140 | (bxoubsr 33) 141 | (* (longify 0xc4ceb9fe1a85ec53)) 142 | (bxoubsr 33) 143 | (bit-or 1) 144 | (as-> z# 145 | (cond-> z# 146 | (> 24 (-> z# 147 | (bxoubsr 1) 148 | long-bit-count)) ;;; (Long/bitCount) 149 | (bit-xor (longify 0xaaaaaaaaaaaaaaaa)))))) 150 | 151 | (def ^{:private true :const true} double-unit (/ 1.0 (double (bit-set 0 53)))) 152 | ;; Java: 0x1.0p-53 or (1.0 / (1L << 53)) 153 | 154 | (deftype JavaUtilSplittableRandom [^long gamma ^long state] 155 | IRandom 156 | (rand-long [_] 157 | (-> state (+ gamma) (mix-64))) 158 | (rand-double [this] 159 | (* double-unit (unsigned-bit-shift-right (long (rand-long this)) 11))) 160 | (split [this] 161 | (let [state' (+ gamma state) 162 | state'' (+ gamma state') 163 | gamma' (mix-gamma state'')] 164 | [(JavaUtilSplittableRandom. gamma state'') 165 | (JavaUtilSplittableRandom. gamma' (mix-64 state'))])) 166 | (split-n [this n] 167 | ;; imitates a particular series of 2-way splits, but avoids the 168 | ;; intermediate allocation. See the `split-n-spec` for a test of 169 | ;; the equivalence to 2-way splits. 170 | (let [n (long n)] 171 | (case n 172 | 0 [] 173 | 1 [this] 174 | (let [n-dec (dec n)] 175 | (loop [state state 176 | ret (transient [])] 177 | (if (= n-dec (count ret)) 178 | (-> ret 179 | (conj! (JavaUtilSplittableRandom. gamma state)) 180 | (persistent!)) 181 | (let [state' (+ gamma state) 182 | state'' (+ gamma state') 183 | gamma' (mix-gamma state'') 184 | new-rng (JavaUtilSplittableRandom. gamma' (mix-64 state'))] 185 | (recur state'' (conj! ret new-rng)))))))))) 186 | 187 | (def ^:private golden-gamma 188 | (longify 0x9e3779b97f4a7c15)) 189 | 190 | (defn make-java-util-splittable-random 191 | [^long seed] 192 | (JavaUtilSplittableRandom. golden-gamma seed)) 193 | 194 | ;; some global state to make sure that seedless calls to make-random 195 | ;; return independent results 196 | 197 | ;;; DM: Added 198 | ;;; Unfortunately, this solution requires ThreadLocal values. 199 | ;;; We do not have an internal way to create static fields in a gen-class so that we could use ThreadStatic. 200 | ;;; And ThreadStatic in CLR was only introduced in 4.0. 201 | ;;; So, we use the equivalent of the old way in 3.5 and use the new way in 4.0 only. 202 | 203 | ;;; This duplicates compile-if from clojure/core/reducers. 204 | 205 | (defmacro ^:private compile-if 206 | "Evaluate `exp` and if it returns logical true and doesn't error, expand to 207 | `then`. Else expand to `else`. 208 | 209 | (compile-if (Class/forName \"java.util.concurrent.ForkJoinTask\") 210 | (do-cool-stuff-with-fork-join) 211 | (fall-back-to-executor-services))" 212 | [exp then else] 213 | (if (try (eval exp) 214 | (catch Exception _ false)) ;;; Throwable 215 | `(do ~then) 216 | `(do ~else))) 217 | 218 | 219 | ;;;(def ^:private next-rng 220 | ;;; "Returns a random-number generator. Successive calls should return 221 | ;;; independent results." 222 | ;;; (let [a (atom (make-java-util-splittable-random (Environment/TickCount))) ;;; (System/currentTimeMillis) 223 | ;;; 224 | ;;; thread-local 225 | ;;; (proxy [ThreadLocal] [] 226 | ;;; (initialValue [] 227 | ;;; (first (split (swap! a #(second (split %)))))))] 228 | ;;; (fn [] 229 | ;;; (let [rng (.get thread-local) 230 | ;;; [rng1 rng2] (split rng)] 231 | ;;; (.set thread-local rng2) 232 | ;;; rng1)))) 233 | 234 | (compile-if 235 | (Type/GetType "System.Threading.ThreadLocal`1") 236 | (do 237 | (def ^:private next-rng 238 | "Returns a random-number generator. Successive calls should return 239 | independent results." 240 | (let [a (atom (make-java-util-splittable-random (Environment/TickCount))) 241 | init-delegate (sys-func [Object] [] (first (split (swap! a #(second (split %)))))) 242 | thread-local (|System.Threading.ThreadLocal`1[System.Object]|. ^|System.Func`1[System.Object]| init-delegate)] 243 | (fn [] 244 | (let [rng (.Value thread-local) 245 | [rng1 rng2] (split rng)] 246 | (.set_Value thread-local rng2) 247 | rng1))))) 248 | (do 249 | (def ^:private next-rng 250 | (fn [] (make-java-util-splittable-random (Environment/TickCount)))))) 251 | 252 | (defn make-random 253 | "Given an optional Long seed, returns an object that satisfies the 254 | IRandom protocol." 255 | ([] (next-rng)) 256 | ([seed] (make-java-util-splittable-random seed))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check/clojure_test.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.clojure-test 11 | (:require #?(:default [clojure.test :as ct] ;;; changed :clj to :default 12 | :cljs [cljs.test :as ct :include-macros true]) 13 | [clojure.test.check :as tc] 14 | [clojure.test.check.clojure-test.assertions] 15 | [clojure.test.check.impl :refer [get-current-time-millis]]) 16 | #?(:cljs (:require-macros [clojure.test.check.clojure-test :refer [defspec]]))) 17 | 18 | (defn assert-check 19 | [{:keys [result result-data] :as m}] 20 | (if-let [error (:clojure.test.check.properties/error result-data)] 21 | (throw error) 22 | (ct/is (clojure.test.check.clojure-test/check? m)))) 23 | 24 | (def ^:dynamic *default-test-count* 100) 25 | 26 | (defn default-reporter-fn 27 | "Default function passed as the :reporter-fn to clojure.test.check/quick-check. 28 | Delegates to clojure.test/report." 29 | [{:keys [type] :as args}] 30 | (case type 31 | :complete 32 | (let [testing-vars #?(:clj ct/*testing-vars* :cljr ct/*testing-vars* ;;; Added :cljr 33 | :cljs (:testing-vars ct/*current-env*)) 34 | params (merge (select-keys args [:result :num-tests :seed 35 | :time-elapsed-ms]) 36 | (when (seq testing-vars) 37 | {:test-var (-> testing-vars first meta :name name)}))] 38 | (ct/report {:type :clojure.test.check.clojure-test/complete 39 | :clojure.test.check.clojure-test/property (:property args) 40 | :clojure.test.check.clojure-test/complete params})) 41 | 42 | :trial 43 | (ct/report {:type :clojure.test.check.clojure-test/trial 44 | :clojure.test.check.clojure-test/property (:property args) 45 | :clojure.test.check.clojure-test/trial [(:num-tests args) 46 | (:num-tests-total args)]}) 47 | 48 | :failure 49 | (ct/report {:type :clojure.test.check.clojure-test/shrinking 50 | :clojure.test.check.clojure-test/property (:property args) 51 | :clojure.test.check.clojure-test/params (vec (:fail args))}) 52 | 53 | :shrunk 54 | (ct/report {:type :clojure.test.check.clojure-test/shrunk 55 | :clojure.test.check.clojure-test/property (:property args) 56 | :clojure.test.check.clojure-test/params (-> args :shrunk :smallest vec)}) 57 | nil)) 58 | 59 | (def ^:dynamic *default-opts* 60 | "The default options passed to clojure.test.check/quick-check 61 | by defspec." 62 | {:reporter-fn default-reporter-fn}) 63 | 64 | (defn process-options 65 | {:no-doc true} 66 | [options] 67 | (cond (nil? options) (merge {:num-tests *default-test-count*} *default-opts*) 68 | (number? options) (assoc *default-opts* :num-tests options) 69 | (map? options) (merge {:num-tests *default-test-count*} 70 | *default-opts* 71 | options) 72 | :else (throw (ex-info (str "Invalid defspec options: " (pr-str options)) 73 | {:bad-options options})))) 74 | 75 | (defmacro defspec 76 | "Defines a new clojure.test test var that uses `quick-check` to verify the 77 | property, running num-times trials by default. You can call the function defined as `name` 78 | with no arguments to trigger this test directly (i.e., without starting a 79 | wider clojure.test run). If called with arguments, the first argument is the number of 80 | trials, optionally followed by keyword arguments as defined for `quick-check`." 81 | {:arglists '([name property] [name num-tests? property] [name options? property])} 82 | ([name property] `(defspec ~name nil ~property)) 83 | ([name options property] 84 | `(defn ~(vary-meta name assoc 85 | ::defspec true 86 | :test `(fn [] 87 | (clojure.test.check.clojure-test/assert-check 88 | (assoc (~name) :test-var (str '~name))))) 89 | {:arglists '([] ~'[num-tests & {:keys [seed max-size reporter-fn]}])} 90 | ([] (let [options# (process-options ~options)] 91 | (apply ~name (:num-tests options#) (apply concat options#)))) 92 | ([times# & {:as quick-check-opts#}] 93 | (let [options# (merge (process-options ~options) quick-check-opts#)] 94 | (apply 95 | tc/quick-check 96 | times# 97 | (vary-meta ~property assoc :name '~name) 98 | (apply concat options#))))))) 99 | 100 | (def ^:dynamic *report-trials* 101 | "Controls whether property trials should be reported via clojure.test/report. 102 | Valid values include: 103 | 104 | * false - no reporting of trials (default) 105 | * a function - will be passed a clojure.test/report-style map containing 106 | :clojure.test.check/property and :clojure.test.check/trial slots 107 | * true - provides quickcheck-style trial reporting (dots) via 108 | `trial-report-dots` 109 | 110 | (Note that all reporting requires running `quick-check` within the scope of a 111 | clojure.test run (via `test-ns`, `test-all-vars`, etc.)) 112 | 113 | Reporting functions offered by clojure.test.check include `trial-report-dots` and 114 | `trial-report-periodic` (which prints more verbose trial progress information 115 | every `*trial-report-period*` milliseconds)." 116 | false) 117 | 118 | (def ^:dynamic *report-shrinking* 119 | "If true, a verbose report of the property being tested, the 120 | failing return value, and the arguments provoking that failure is emitted 121 | prior to the start of the shrinking search." 122 | false) 123 | 124 | (def ^:dynamic *trial-report-period* 125 | "Milliseconds between reports emitted by `trial-report-periodic`." 126 | 10000) 127 | 128 | (def ^:private last-trial-report (atom 0)) 129 | 130 | (defn- get-property-name 131 | [{property-fun ::property :as report-map}] 132 | (or (-> property-fun meta :name) (ct/testing-vars-str report-map))) 133 | 134 | (defn with-test-out* [f] 135 | #?(:default (ct/with-test-out (f)) ;;; changed :clj to :default 136 | :cljs (f))) 137 | 138 | (defn trial-report-periodic 139 | "Intended to be bound as the value of `*report-trials*`; will emit a verbose 140 | status every `*trial-report-period*` milliseconds, like this one: 141 | 142 | Passing trial 3286 / 5000 for (your-test-var-name-here) (:)" 143 | [m] 144 | (let [t (get-current-time-millis)] 145 | (when (> (- t *trial-report-period*) @last-trial-report) 146 | (with-test-out* 147 | (fn [] 148 | (println "Passing trial" 149 | (-> m ::trial first) "/" (-> m ::trial second) 150 | "for" (get-property-name m)))) 151 | (reset! last-trial-report t)))) 152 | 153 | (defn trial-report-dots 154 | "Intended to be bound as the value of `*report-trials*`; will emit a single 155 | dot every 1000 trials reported." 156 | [{[so-far total] ::trial}] 157 | (when (pos? so-far) 158 | (when (zero? (mod so-far 1000)) 159 | (print ".") 160 | (flush)) 161 | (when (== so-far total) (println)))) 162 | 163 | (def ^:dynamic *report-completion* 164 | "If true, completed tests report test-var, num-tests and seed. Failed tests 165 | report shrunk results. Defaults to true." 166 | true) 167 | 168 | (when #?(:clj true :cljr true :cljs (not (and *ns* (re-matches #".*\$macros" (name (ns-name *ns*)))))) ;;; Added :cljr 169 | ;; This check accomodates a number of tools that rebind ct/report 170 | ;; to be a regular function instead of a multimethod, and may do 171 | ;; so before this code is loaded (see TCHECK-125) 172 | (if-not (instance? #?(:clj clojure.lang.MultiFn :cljr clojure.lang.MultiFn :cljs MultiFn) ct/report) ;;; Added :cljr 173 | (binding [*out* #?(:clj *err* :cljr *err* :cljs *out*)] ;;; Added :cljr 174 | (println "clojure.test/report is not a multimethod, some reporting functions have been disabled.")) ;;; Added :cljr 175 | (let [begin-test-var-method (get-method ct/report #?(:clj :begin-test-var :cljr :begin-test-var 176 | :cljs [::ct/default :begin-test-var]))] 177 | (defmethod ct/report #?(:clj :begin-test-var :cljr :begin-test-var ;;; Added :cljr 178 | :cljs [::ct/default :begin-test-var]) [m] 179 | (reset! last-trial-report (get-current-time-millis)) 180 | (when begin-test-var-method (begin-test-var-method m))) 181 | 182 | (defmethod ct/report #?(:clj ::trial :cljr ::trial :cljs [::ct/default ::trial]) [m] ;;; Added :cljr 183 | (when-let [trial-report-fn (and *report-trials* 184 | (if (true? *report-trials*) 185 | trial-report-dots 186 | *report-trials*))] 187 | (trial-report-fn m))) 188 | 189 | (defmethod ct/report #?(:clj ::shrinking :cljr ::shrinking :cljs [::ct/default ::shrinking]) [m] ;;; Added :cljr 190 | (when *report-shrinking* 191 | (with-test-out* 192 | (fn [] 193 | (println "Shrinking" (get-property-name m) 194 | "starting with parameters" (pr-str (::params m))))))) 195 | 196 | (defmethod ct/report #?(:clj ::complete :cljr ::complete :cljs [::ct/default ::complete]) [m] ;;; Added :cljr 197 | (when *report-completion* 198 | (prn (::complete m)))) 199 | 200 | (defmethod ct/report #?(:clj ::shrunk :cljr ::shrunk :cljs [::ct/default ::shrunk]) [m] ;;; Added :cljr 201 | (when *report-completion* 202 | (with-test-out* 203 | (fn [] (prn m)))))))) -------------------------------------------------------------------------------- /src/test/clojure/clojure/test/check/clojure_test_test.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check.clojure-test-test 11 | (:require [clojure.set :as set] 12 | [clojure.string :as str] 13 | #?@(:cljs 14 | [[cljs.test 15 | :as test 16 | :include-macros true 17 | :refer [test-var] 18 | :refer-macros [is deftest testing]] 19 | [cljs.reader :refer [read-string]]]) 20 | #?(:clj [clojure.test :as test :refer :all] ;;; Added :cljr clause 21 | :cljr [clojure.test :as test :refer :all]) 22 | [clojure.test.check.generators :as gen] 23 | [clojure.test.check.properties :as prop] 24 | [clojure.test.check.clojure-test :as ct :refer [defspec]])) 25 | 26 | (declare ^:dynamic test-report) 27 | 28 | (defn capturing-report [reports m] 29 | (swap! reports conj m) 30 | (test-report m)) 31 | 32 | (defn ^:private capture-test-var 33 | "Returns map of :reports, :report-counters, :out, and :test-out." 34 | [v] 35 | (let [reports (atom [])] 36 | (binding [test-report test/report 37 | test/report (partial capturing-report reports)] 38 | #?(:default ;;; changed :clj to :default 39 | (binding [*report-counters* (ref *initial-report-counters*) 40 | *test-out* (System.IO.StringWriter.) ;;; java.io.StringWriter. 41 | *testing-contexts* (list) 42 | *testing-vars* (list)] 43 | (let [out (with-out-str (test-var v))] 44 | {:reports @reports 45 | :report-counters @*report-counters* 46 | :out out 47 | :test-out (str *test-out*)})) 48 | :cljs 49 | (binding [test/*current-env* (test/empty-env)] 50 | (let [out (with-out-str (test-var v))] 51 | ;; cljs.test doesn't distinguish between *out* and *test-out* 52 | {:reports @reports 53 | :report-counters (:report-counters test/*current-env*) 54 | :out out 55 | :test-out out})))))) 56 | 57 | (defspec default-trial-counts 58 | (prop/for-all* [gen/small-integer] (constantly true))) 59 | 60 | (deftest can-use-num-tests-default-value 61 | (let [{:keys [reports]} (capture-test-var #'default-trial-counts) 62 | num-tests (->> reports 63 | (filter #(= ::ct/complete (:type %))) 64 | first 65 | ::ct/complete 66 | :num-tests)] 67 | (is (= num-tests ct/*default-test-count*)))) 68 | 69 | (deftest tcheck-116-debug-prn-should-be-optional 70 | (testing "bind ct/*report-completion* to false to supress completion report" 71 | (binding [ct/*report-completion* false] 72 | (let [{:keys [out]} (capture-test-var #'default-trial-counts)] 73 | (is (= out ""))))) 74 | 75 | (testing "report completions by default" 76 | (let [{:keys [out]} (capture-test-var #'default-trial-counts) 77 | completion (-> out read-string (select-keys [:test-var :result :num-tests]))] 78 | (is (= completion {:test-var "default-trial-counts" 79 | :result true 80 | :num-tests ct/*default-test-count*}))))) 81 | 82 | (def trial-counts-num-tests 5000) 83 | (defspec trial-counts trial-counts-num-tests 84 | (prop/for-all* [gen/small-integer] (constantly true))) 85 | 86 | (deftest can-specify-num-tests 87 | (let [{:keys [reports]} (capture-test-var #'trial-counts) 88 | num-tests (->> reports 89 | (filter #(= ::ct/complete (:type %))) 90 | first 91 | ::ct/complete 92 | :num-tests)] 93 | (is (= num-tests trial-counts-num-tests)))) 94 | 95 | (deftest can-report-completion-with-specified-num-tests 96 | (let [{:keys [out]} (capture-test-var #'trial-counts) 97 | completion (-> out read-string (select-keys [:test-var :result :num-tests]))] 98 | (is (= completion {:test-var "trial-counts" 99 | :result true 100 | :num-tests trial-counts-num-tests})))) 101 | 102 | (deftest can-report-trials-with-dots 103 | (binding [ct/*report-trials* true] 104 | (let [{:keys [out]} (capture-test-var #'trial-counts)] 105 | (is (re-matches #?(:clj (java.util.regex.Pattern/compile "(?s)\\.{5}.+") 106 | :cljs #"\.{5}[\s\S]+" :cljr #"(?s)\.{5}.+" ) ;;; Added :cljr clause 107 | out))))) 108 | 109 | (defspec long-running-spec 1000 110 | (prop/for-all* 111 | [] 112 | #(do 113 | #?(:clj (Thread/sleep 1) 114 | :cljr (System.Threading.Thread/Sleep 1) ;;; Added :cljr clause 115 | :cljs 116 | (let [start (.valueOf (js/Date.))] 117 | ;; let's do some busy waiting for 1 msec, so we avoid setTimeout 118 | ;; which would make our test async 119 | (while (= start 120 | (.valueOf (js/Date.))) 121 | (apply + (range 50))))) 122 | true))) 123 | 124 | (defn wait-for-clock-tick 125 | "Allow time to progress to avoid timing issues with sub-millisecond code." 126 | [start] 127 | #?(:clj (Thread/sleep 1) :cljr (System.Threading.Thread/Sleep 10) ;;; Added :cljr clause 128 | :cljs (while (>= start (.valueOf (js/Date.))) 129 | (apply + (range 50))))) 130 | 131 | (deftest can-report-trials-periodically 132 | (binding [ct/*report-trials* ct/trial-report-periodic 133 | ct/*trial-report-period* 500] 134 | (let [last-trial-report @#'ct/last-trial-report] 135 | 136 | (testing "test/report with {:type :begin-test-var} increments last-trial-report" 137 | (let [initial-trial-report @last-trial-report] 138 | (wait-for-clock-tick initial-trial-report) 139 | (test/report {:type :begin-test-var}) 140 | (is (> @last-trial-report initial-trial-report)))) 141 | 142 | (testing "test/report with other :type does not increment last-trial-report" 143 | (let [initial-trial-report @last-trial-report] 144 | (wait-for-clock-tick initial-trial-report) 145 | (test/report {:type :end-test-var}) 146 | (is (= @last-trial-report initial-trial-report)))) 147 | 148 | (testing "running the test increments last-trial-report" 149 | (let [initial-trial-report @last-trial-report] 150 | (wait-for-clock-tick initial-trial-report) 151 | (is (re-seq 152 | #"(Passing trial \d{3} / 1000 for long-running-spec(\r)?\n)+" ;;; added optional \r 153 | (:test-out 154 | (capture-test-var #'long-running-spec)))) 155 | (is (> @last-trial-report initial-trial-report))))))) 156 | 157 | (defn- vector-elements-are-unique* 158 | [v] 159 | (== (count v) (count (distinct v)))) 160 | 161 | (def ^:private vector-elements-are-unique 162 | (prop/for-all* 163 | [(gen/vector gen/small-integer)] 164 | vector-elements-are-unique*)) 165 | 166 | (defspec this-is-supposed-to-fail 100 vector-elements-are-unique) 167 | 168 | (deftest can-report-failures 169 | (let [{:keys [test-out]} (capture-test-var #'this-is-supposed-to-fail) 170 | [result-line expected-line actual-line & more] (->> (str/split-lines test-out) 171 | ;; skip any ::shrunk messages 172 | (drop-while #(not (re-find #"^FAIL" %))))] 173 | (is (re-find #"^FAIL in \(this-is-supposed-to-fail\) " result-line)) 174 | #_#?(:clj (is (re-find #"\(clojure_test_test\.cljc:\d+\)$" result-line))) ;;; We do not get file info back from the stack trace 175 | (is (= expected-line "expected: {:result true}")) 176 | (let [actual (read-string (subs actual-line 10))] 177 | (is (set/subset? #{:result :result-data :seed :failing-size :num-tests :fail :shrunk} 178 | (set (keys actual)))) 179 | (is (= false (:result actual)))) 180 | (is (= more '(""))))) ;;; (is (nil? more)) -- not sure why we get an extra blank line, and don't care. 181 | 182 | (deftest can-report-shrinking 183 | (testing "don't emit Shrinking messages by default" 184 | (let [{:keys [report-counters test-out]} (capture-test-var #'this-is-supposed-to-fail)] 185 | (is (== 1 (:fail report-counters))) 186 | (is (not (re-find #"Shrinking" test-out))))) 187 | 188 | (testing "bind *report-shrinking* to true to emit Shrinking messages" 189 | (binding [ct/*report-shrinking* true] 190 | (let [{:keys [report-counters test-out]} (capture-test-var #'this-is-supposed-to-fail)] 191 | (is (== 1 (:fail report-counters))) 192 | (is (re-seq #"Shrinking this-is-supposed-to-fail starting with parameters \[\[[\s\S]+" 193 | test-out)))))) 194 | 195 | (deftest tcheck-118-pass-shrunk-input-on-to-clojure-test 196 | (let [{trial ::ct/trial, shrinking ::ct/shrinking, shrunk ::ct/shrunk} 197 | (group-by :type (:reports (capture-test-var #'this-is-supposed-to-fail)))] 198 | ;; should have had some successful runs because the initial size 199 | ;; is too small for duplicates 200 | (is (seq trial)) 201 | 202 | (is (= 1 (count shrinking))) 203 | (is (not (-> shrinking first ::ct/params first (->> (apply distinct?))))) 204 | 205 | (is (= 1 (count shrunk))) 206 | (let [[a b & more] (-> shrunk first ::ct/params first)] 207 | (is (empty? more)) 208 | (is (and a b (= a b)))))) 209 | 210 | (deftest can-report-shrunk 211 | (testing "supress shrunk report when ct/*report-completion* is bound to false" 212 | (binding [ct/*report-completion* false] 213 | (let [{:keys [test-out]} (capture-test-var #'this-is-supposed-to-fail)] 214 | (is (not (re-find #":type :clojure.test.check.clojure-test/shrunk" test-out)))))) 215 | 216 | (testing "report shrunk by default" 217 | (let [{:keys [test-out]} (capture-test-var #'this-is-supposed-to-fail)] 218 | (is (re-find #":type :clojure.test.check.clojure-test/shrunk" test-out))))) 219 | 220 | (defspec this-throws-an-exception 221 | (prop/for-all [x gen/nat] 222 | (throw (ex-info "this property is terrible" {})))) 223 | 224 | (deftest can-re-throw-exceptions-to-clojure-test 225 | (let [{:keys [report-counters test-out]} (capture-test-var #'this-throws-an-exception)] 226 | (is (= report-counters {:test 1, :pass 0, :fail 0, :error 1})) 227 | (is (re-find #"ERROR in \(this-throws-an-exception\)" test-out)) 228 | ;; TCHECK-151 229 | (is (= 1 (count (re-seq #"this property is terrible" test-out))) 230 | "Only prints exceptions twice"))) 231 | 232 | 233 | (defn test-ns-hook 234 | "Run only tests defined by deftest, ignoring those defined by defspec." 235 | [] 236 | (let [tests (->> (vals (ns-interns #?(:default (find-ns 'clojure.test.check.clojure-test-test) ;; changed :clj to :default 237 | :cljs 'clojure.test.check.clojure-test-test))) 238 | (filter #(let [m (meta %)] 239 | (and (:test m) 240 | (not (::ct/defspec m))))) 241 | (sort-by #(:line (meta %))))] 242 | (test/test-vars tests))) -------------------------------------------------------------------------------- /src/main/clojure/clojure/test/check.cljc: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey, Reid Draper, and contributors. 2 | ; All rights reserved. 3 | ; The use and distribution terms for this software are covered by the 4 | ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 5 | ; which can be found in the file epl-v10.html at the root of this distribution. 6 | ; By using this software in any fashion, you are agreeing to be bound by 7 | ; the terms of this license. 8 | ; You must not remove this notice, or any other, from this software. 9 | 10 | (ns clojure.test.check 11 | (:require [clojure.test.check.generators :as gen] 12 | [clojure.test.check.random :as random] 13 | [clojure.test.check.results :as results] 14 | [clojure.test.check.rose-tree :as rose] 15 | [clojure.test.check.impl :refer [get-current-time-millis]])) 16 | 17 | (declare shrink-loop failure) 18 | 19 | (defn- make-rng 20 | [seed] 21 | (if seed 22 | [seed (random/make-random seed)] 23 | (let [non-nil-seed (get-current-time-millis)] 24 | [non-nil-seed (random/make-random non-nil-seed)]))) 25 | 26 | (defn- complete 27 | [property num-trials seed start-time reporter-fn] 28 | (let [time-elapsed-ms (- (get-current-time-millis) start-time)] 29 | (reporter-fn {:type :complete 30 | :property property 31 | :result true 32 | :pass? true 33 | :num-tests num-trials 34 | :time-elapsed-ms time-elapsed-ms 35 | :seed seed}) 36 | {:result true 37 | :pass? true 38 | :num-tests num-trials 39 | :time-elapsed-ms time-elapsed-ms 40 | :seed seed})) 41 | 42 | 43 | (defn ^:private legacy-result 44 | "Returns a value for the legacy :result key, which has the peculiar 45 | property of conflating returned exceptions with thrown exceptions." 46 | [result] 47 | (if (satisfies? results/Result result) 48 | (let [d (results/result-data result)] 49 | (if-let [[_ e] (find d :clojure.test.check.properties/error)] 50 | #?(:clj e :cljr e ;;; added :cljr 51 | :cljs (if (instance? js/Error e) 52 | e 53 | (ex-info "Non-Error object thrown in test" 54 | {} 55 | e))) 56 | (results/pass? result))) 57 | result)) 58 | 59 | (defn quick-check 60 | "Tests `property` `num-tests` times. 61 | 62 | Takes several optional keys: 63 | 64 | `:seed` 65 | Can be used to re-run previous tests, as the seed used is returned 66 | after a test is run. 67 | 68 | `:max-size`. 69 | can be used to control the 'size' of generated values. The size will 70 | start at 0, and grow up to max-size, as the number of tests increases. 71 | Generators will use the size parameter to bound their growth. This 72 | prevents, for example, generating a five-thousand element vector on 73 | the very first test. 74 | 75 | `:reporter-fn` 76 | A callback function that will be called at various points in the test 77 | run, with a map like: 78 | 79 | ;; called after a passing trial 80 | {:type :trial 81 | :args [...] 82 | :num-tests 83 | :num-tests-total 84 | :seed 42 85 | :pass? true 86 | :property #<...> 87 | :result true 88 | :result-data {...}} 89 | 90 | ;; called after the first failing trial 91 | {:type :failure 92 | :fail [...failing args...] 93 | :failing-size 13 94 | :num-tests 95 | :pass? false 96 | :property #<...> 97 | :result false/exception 98 | :result-data {...} 99 | :seed 42} 100 | 101 | It will also be called on :complete, :shrink-step and :shrunk. Many 102 | of the keys also appear in the quick-check return value, and are 103 | documented below. 104 | 105 | If the test passes, the return value will be something like: 106 | 107 | {:num-tests 100, 108 | :pass? true, 109 | :result true, 110 | :seed 1561826505982, 111 | :time-elapsed-ms 24} 112 | 113 | If the test fails, the return value will be something like: 114 | 115 | {:fail [0], 116 | :failed-after-ms 0, 117 | :failing-size 0, 118 | :num-tests 1, 119 | :pass? false, 120 | :result false, 121 | :result-data nil, 122 | :seed 1561826506080, 123 | :shrunk 124 | {:depth 0, 125 | :pass? false, 126 | :result false, 127 | :result-data nil, 128 | :smallest [0], 129 | :time-shrinking-ms 0, 130 | :total-nodes-visited 0}} 131 | 132 | The meaning of the individual entries is: 133 | 134 | :num-tests 135 | The total number of trials that was were run, not including 136 | shrinking (if applicable) 137 | 138 | :pass? 139 | A boolean indicating whether the test passed or failed 140 | 141 | :result 142 | A legacy entry that is similar to :pass? 143 | 144 | :seed 145 | The seed used for the entire test run; can be used to reproduce 146 | a test run by passing it as the :seed option to quick-check 147 | 148 | :time-elapsed-ms 149 | The total time, in milliseconds, of a successful test run 150 | 151 | :fail 152 | The generated values for the first failure; note that this is 153 | always a vector, since prop/for-all can have multiple clauses 154 | 155 | :failed-after-ms 156 | The total time, in milliseconds, spent finding the first failing 157 | 158 | trial 159 | :failing-size 160 | The value of the size parameter used to generate the first 161 | failure 162 | 163 | :result-data 164 | The result data, if any, of the first failing trial (to take 165 | advantage of this a property must return an object satisfying 166 | the clojure.test.check.results/Result protocol) 167 | 168 | :shrunk 169 | A map of data about the shrinking process; nested keys that 170 | appear at the top level have the same meaning; other keys are 171 | documented next 172 | 173 | :shrunk / :depth 174 | The depth in the shrink tree that the smallest failing instance 175 | was found; this is essentially the idea of how many times the 176 | original failure was successfully shrunk 177 | 178 | :smallest 179 | The smallest values found in the shrinking process that still 180 | fail the test; this is a vector of the same type as :fail 181 | 182 | :time-shrinking-ms 183 | The total time, in milliseconds, spent shrinking 184 | 185 | :total-nodes-visited 186 | The total number of steps in the shrinking process 187 | 188 | Examples: 189 | 190 | (def p (for-all [a gen/nat] (> (* a a) a))) 191 | 192 | (quick-check 100 p) 193 | (quick-check 200 p 194 | :seed 42 195 | :max-size 50 196 | :reporter-fn (fn [m] 197 | (when (= :failure (:type m)) 198 | (println \"Uh oh...\"))))" 199 | [num-tests property & {:keys [seed max-size reporter-fn] 200 | :or {max-size 200, reporter-fn (constantly nil)}}] 201 | (let [[created-seed rng] (make-rng seed) 202 | size-seq (gen/make-size-range-seq max-size) 203 | start-time (get-current-time-millis)] 204 | (loop [so-far 0 205 | size-seq size-seq 206 | rstate rng] 207 | (if (== so-far num-tests) 208 | (complete property num-tests created-seed start-time reporter-fn) 209 | (let [[size & rest-size-seq] size-seq 210 | [r1 r2] (random/split rstate) 211 | result-map-rose (gen/call-gen property r1 size) 212 | result-map (rose/root result-map-rose) 213 | result (:result result-map) 214 | args (:args result-map) 215 | so-far (inc so-far)] 216 | (if (results/pass? result) 217 | (do 218 | (reporter-fn {:type :trial 219 | :args args 220 | :num-tests so-far 221 | :num-tests-total num-tests 222 | :pass? true 223 | :property property 224 | :result result 225 | :result-data (results/result-data result) 226 | :seed seed}) 227 | (recur so-far rest-size-seq r2)) 228 | (failure property result-map-rose so-far size 229 | created-seed start-time reporter-fn))))))) 230 | 231 | (defn- smallest-shrink 232 | [total-nodes-visited depth smallest start-time] 233 | (let [{:keys [result]} smallest] 234 | {:total-nodes-visited total-nodes-visited 235 | :depth depth 236 | :pass? false 237 | :result (legacy-result result) 238 | :result-data (results/result-data result) 239 | :time-shrinking-ms (- (get-current-time-millis) start-time) 240 | :smallest (:args smallest)})) 241 | 242 | (defn- shrink-loop 243 | "Shrinking a value produces a sequence of smaller values of the same type. 244 | Each of these values can then be shrunk. Think of this as a tree. We do a 245 | modified depth-first search of the tree: 246 | 247 | Do a non-exhaustive search for a deeper (than the root) failing example. 248 | Additional rules added to depth-first search: 249 | * If a node passes the property, you may continue searching at this depth, 250 | but not backtrack 251 | * If a node fails the property, search its children 252 | The value returned is the left-most failing example at the depth where a 253 | passing example was found. 254 | 255 | Calls reporter-fn on every shrink step." 256 | [rose-tree reporter-fn] 257 | (let [start-time (get-current-time-millis) 258 | shrinks-this-depth (rose/children rose-tree)] 259 | (loop [nodes shrinks-this-depth 260 | current-smallest (rose/root rose-tree) 261 | total-nodes-visited 0 262 | depth 0] 263 | (if (empty? nodes) 264 | (smallest-shrink total-nodes-visited depth current-smallest start-time) 265 | (let [;; can't destructure here because that could force 266 | ;; evaluation of (second nodes) 267 | head (first nodes) 268 | tail (rest nodes) 269 | result (:result (rose/root head)) 270 | args (:args (rose/root head)) 271 | pass? (results/pass? result) 272 | reporter-fn-arg {:type :shrink-step 273 | :shrinking {:args args 274 | :depth depth 275 | :pass? (boolean pass?) 276 | :result result 277 | :result-data (results/result-data result) 278 | :smallest (:args current-smallest) 279 | :total-nodes-visited total-nodes-visited}}] 280 | (if pass? 281 | ;; this node passed the test, so now try testing its right-siblings 282 | (do 283 | (reporter-fn reporter-fn-arg) 284 | (recur tail current-smallest (inc total-nodes-visited) depth)) 285 | ;; this node failed the test, so check if it has children, 286 | ;; if so, traverse down them. If not, save this as the best example 287 | ;; seen now and then look at the right-siblings 288 | ;; children 289 | (let [new-smallest (rose/root head)] 290 | (reporter-fn (assoc-in reporter-fn-arg 291 | [:shrinking :smallest] 292 | (:args new-smallest))) 293 | (if-let [children (seq (rose/children head))] 294 | (recur children new-smallest (inc total-nodes-visited) (inc depth)) 295 | (recur tail new-smallest (inc total-nodes-visited) depth))))))))) 296 | 297 | (defn- failure 298 | [property failing-rose-tree trial-number size seed start-time reporter-fn] 299 | (let [failed-after-ms (- (get-current-time-millis) start-time) 300 | root (rose/root failing-rose-tree) 301 | result (:result root) 302 | failure-data {:fail (:args root) 303 | :failing-size size 304 | :num-tests trial-number 305 | :pass? false 306 | :property property 307 | :result (legacy-result result) 308 | :result-data (results/result-data result) 309 | :failed-after-ms failed-after-ms 310 | :seed seed}] 311 | 312 | (reporter-fn (assoc failure-data :type :failure)) 313 | 314 | (let [shrunk (shrink-loop failing-rose-tree 315 | #(reporter-fn (merge failure-data %)))] 316 | (reporter-fn (assoc failure-data 317 | :type :shrunk 318 | :shrunk shrunk)) 319 | (-> failure-data 320 | (dissoc :property) 321 | (assoc :shrunk shrunk))))) --------------------------------------------------------------------------------