pax_global_header00006660000000000000000000000064135451321110014506gustar00rootroot0000000000000052 comment=36f9bf9d2b28943fd0ba2842242da09542600e1d qcheck-0.11/000077500000000000000000000000001354513211100126655ustar00rootroot00000000000000qcheck-0.11/.gitignore000066400000000000000000000001331354513211100146520ustar00rootroot00000000000000.*.swp .*.swo _build *.native .session TAGS *.docdir man *.install *.tar.gz *.byte .merlin qcheck-0.11/.gitmodules000066400000000000000000000001241354513211100150370ustar00rootroot00000000000000[submodule "check-fun"] path = check-fun url = https://github.com/jmid/qcheck-fun qcheck-0.11/.header000066400000000000000000000002231354513211100141130ustar00rootroot00000000000000(* QCheck: Random testing for OCaml copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard all rights reserved. *) qcheck-0.11/.ocamlinit000066400000000000000000000000251354513211100146420ustar00rootroot00000000000000 module Q = QCheck;; qcheck-0.11/.travis.yml000066400000000000000000000007711354513211100150030ustar00rootroot00000000000000language: c install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh script: bash -ex .travis-docker.sh services: - docker env: global: - PINS="qcheck:. qcheck-core:. qcheck-ounit:. qcheck-alcotest:." - DISTRO="ubuntu-16.04" - PACKAGE="qcheck" - DEPOPTS="ounit alcotest" matrix: - OCAML_VERSION="4.03" - OCAML_VERSION="4.04" - OCAML_VERSION="4.05" - OCAML_VERSION="4.06" - OCAML_VERSION="4.07" - OCAML_VERSION="4.08" - OCAML_VERSION="4.09" qcheck-0.11/AUTHORS000066400000000000000000000002461354513211100137370ustar00rootroot00000000000000Simon Cruanes Rudi Grinberg Jacques-Pascal Deplaix Jan Midtgaard qcheck-0.11/CHANGELOG.md000066400000000000000000000126521354513211100145040ustar00rootroot00000000000000# Changes ## 0.11 - Add `QCheck.Gen.{string_of,string_readable}` - fix `int_bound` bound inclusiveness problem - change implementation of `int_bound` to generate values using `Random.State.int` for `bound < 2^30` - add weighted shuffled lists generator - add `float_range` to generate a floating-point number in the given range (inclusive) - add `float_bound_inclusive` and `float_bound_exclusive` to generate floating-point numbers between 0 and a given bound ## 0.10 - `Shrink`: decompose Shrink.list into Shrink.list_spine and Shrink.list_elems - `Gen.fix` has a more general and useful type - update README to include `Rely` section (qcheck now available for reason-native!) - Fix stat printing - speed-up list shrinker - Better int shrinking - core: modify proba distributions again, add `big_nat` - feat: add `small_array`, modify distributions - print number of warnings in runner's summary - refactor: modify type of results to make them more accurate - feat: warn/fail if too many tests passed only b/c precondition failed ## 0.9 - add `qcheck-ounit` sublibrary - use environment variables to configure `qcheck-alcotest` tests - alcotest backend for qcheck - make `qcheck.ounit` tests verbose by default - make `qcheck` is a compatibility library, depends on `qcheck-core` - split lib into `qcheck` and `qcheck.ounit` - add `TestResult.is_success` helper - give access to list of instances in test results - allow setting `time_between_msg` in runner - chore: remove submodule - chore: add travis support - doc: explanations about qcheck.ounit runners - doc: update readme ## 0.8 - migrate to jbuilder - fix warnings - add some useful functions - update oasis files (close #48) - update copyright header (closes #47) ## 0.7 - switch to BSD license, make it more explicit (close #43) - improve multi-line message printing in ounit (closes #46) - fix complexity of `add_stat` - allow negative entries in statistics (see #40) - add a way for tests to report messages to the user (see #39) - add `QCheck.Shrink.int_aggressive` and make default int shrinker faster - shrinker for `map_keep_input` - add `QCheck.set_gen`, missing for some reason - more compact verbose output (see #33) - better handling of dynamic progress line - Add colors to checkmarks in verbose mode - improve statistics display for runner - recover exception of shrunk input - print status line before the solving starts ## 0.6 - add `find_example` and `find_example_gen` to synthesize values from properties (see #31) - add `QCheck.gen` for accessing the random generator easily - colorful runners, with `--no-colors` to disable them - add more generator (for corner cases) - better generation of random functions (see #8), using `Observable` and an efficient internal representation using heterogeneous tuples, printing, and shrinking. deprecate old hacks. - add statistics gathering and display (see #30) - better printing of Tuple - improve `Shrink.{array,list}` (see #32) - Change asserts to raise `Invalid_arg` (following the doc), and update doc - Change `Gen.{int_bount,int_range}` to support up to 2^62 ## 0.5.3.1 - fix regression in runner output (print results of `collect`) - update the `@since` tags ## 0.5.3 - missing char in `Gen.char` (close #23) - add `test` and `doc` to opam - add `small_list` generator - add `~long_factor` to tests and runner, for long tests - add more examples in readme, better doc for runners - improved reporting when running qcheck tests - add `Test.get_count` on test cells ## 0.5.2 - Add cli option for backtraces in `QCheck_runner` - Add test case for raising exception - Better handling of backtraces - All tests now have a name - Add step function called on each instance in a test - make `small_int` a deprecated alias to `small_nat` - add `small_signed_int` - remove some warnings - use safe-string, and fix related bug - Add long tests options to `QCheck_runner` - Add `length` specification for `to_ounit2_test` - Added paragraph in README about long tests ## 0.5.1 - document exceptions - add `small_nat`, change `small_int` semantics (close #10) - add `QCheck.assume_fail` - add `QCheck.assume`; explain preconditions a bit (close #9) - Polish documentation - Added quad support uniformly ## 0.5 - merge back from `qtest`: big changes in API, shrinking, use `'a arbitrary` type that combines printer, generator, shrinker, etc. (see git log) - merlin file - reorganize sources, `_oasis`, `.merlin`, etc. ## 0.4 - bugfix in `fix_fuel` - if verbose enabled, print each test case - add `QCheck.run_main` - `QCheck_ounit.~::` - add `(>:::)` - add `qcheck_ounit ml{lib,dylib}` - trivial ounit integration - make `test_cell.name` optional - `Arbitrary.fix_fuel(_gen)`: add a recursive case - `Arbitrary.fix_fuel_gen`, similar to `fix_fuel` but threading a state bottom-up to make choices depend on the path - `Arbitrary.fail_fix` to fail in a fixpoint - helper cases for `Arbitrary.fix_fuel` ## 0.3 - get rid of submodule `generator` - `Arbitrary.fix_fuel`, to generate complex recursive structures - new combinators (infix map, applicative funs, shuffle) - remove generator/Generator, and a deprecation warning - output of printers of lists/arrays now parsable by ocaml toplevel ## 0.2 - integrate Gabriel Scherer's `Generator` into `QCheck` - add `|||` - add `Prop.raises` - print the faulty instance in case of error (if a printer is available) - some combinators for `QCheck.Arbitrary` - `QCheck.mk_test` takes more arguments ## 0.1 - oasis based build system - source files qcheck-0.11/LICENSE000066400000000000000000000024711354513211100136760ustar00rootroot00000000000000copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. qcheck-0.11/Makefile000066400000000000000000000022541354513211100143300ustar00rootroot00000000000000 all: build test build: @dune build @install test: @dune runtest --no-buffer clean: @dune clean doc: @dune build @doc example-test: @dune exec example/ounit/QCheck_test.exe example-ounit-test: @dune exec example/ounit/QCheck_ounit_test.exe example-runner: @dune exec example/QCheck_runner_test.exe example-alcotest: @dune exec example/alcotest/QCheck_alcotest_test.exe VERSION=$(shell awk '/^version:/ {print $$2}' qcheck.opam) update_next_tag: @echo "update version to $(VERSION)..." sed -i "s/NEXT_VERSION/$(VERSION)/g" `find src -name '*.ml' -or -name '*.mli'` sed -i "s/NEXT_RELEASE/$(VERSION)/g" `find src -name '*.ml' -or -name '*.mli'` release: update_next_tag @echo "release version $(VERSION)..." git tag -f $(VERSION) ; git push origin :$(VERSION) ; git push origin $(VERSION) opam publish https://github.com/c-cube/qcheck/archive/$(VERSION).tar.gz @echo "review the release, then type 'opam publish submit qcheck.$(VERSION)/'" watch: while find src/ -print0 | xargs -0 inotifywait -e delete_self -e modify ; do \ echo "============ at `date` ==========" ; \ sleep 0.2; \ make all; \ done .PHONY: benchs tests examples update_next_tag watch release qcheck-0.11/README.adoc000066400000000000000000000257541354513211100144670ustar00rootroot00000000000000= QCheck :toc: macro :toclevels: 4 :source-highlighter: pygments QuickCheck inspired property-based testing for OCaml, and combinators to generate random values to run tests on. The documentation can be found https://c-cube.github.io/qcheck/[here]. This library spent some time in https://github.com/vincent-hugot/iTeML[qtest], but is now standalone again! Note that @gasche's https://github.com/gasche/random-generator/[generator library] can be useful too, for generating random values. toc::[] image::https://travis-ci.org/c-cube/qcheck.svg?branch=master[alt="Build Status", link="https://travis-ci.org/c-cube/qcheck"] == Use See the documentation. I also wrote https://cedeela.fr/quickcheck-for-ocaml[a blog post] that explains how to use it and some design choices; however, be warned that the API changed in lots of small ways (in the right direction, I hope) so the code will not work any more. <> is an updated version of the blog post's examples. == Build $ make You can use opam: $ opam install qcheck == License The code is now released under the BSD license. [[examples]] == An Introduction to the Library First, let's see a few tests. Let's open a toplevel (e.g. utop) and type the following to load QCheck: [source,OCaml] ---- #require "qcheck";; ---- NOTE: alternatively, it is now possible to locally do: `dune utop src` to load `qcheck`. === List Reverse is Involutive We write a random test for checking that `List.rev (List.rev l) = l` for any list `l`: [source,OCaml] ---- let test = QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" QCheck.(list small_nat) (fun l -> List.rev (List.rev l) = l);; (* we can check right now the property... *) QCheck.Test.check_exn test;; ---- In the above example, we applied the combinator `list` to the random generator `small_nat` (ints between 0 and 100), to create a new generator of lists of random integers. These builtin generators come with printers and shrinkers which are handy for outputting and minimizing a counterexample when a test fails. Consider the buggy property `List.rev l = l`: [source,OCaml] ---- let test = QCheck.Test.make ~count:1000 ~name:"my_buggy_test" QCheck.(list small_nat) (fun l -> List.rev l = l);; ---- When we run this test we are presented with a counterexample: [source,OCaml] ---- # QCheck.Test.check_exn test;; Exception: QCheck.Test.Test_fail ("my_buggy_test", ["[0; 1] (after 23 shrink steps)"]). ---- In this case QCheck found the minimal counterexample `[0;1]` to the property `List.rev l = l` and it spent 23 steps shrinking it. Now, let's run the buggy test with a decent runner that will print the results nicely (the exact output will change at each run, because of the random seed): ---- # QCheck_runner.run_tests [test];; --- Failure -------------------------------------------------------------------- Test my_buggy_test failed (10 shrink steps): [0; 1] ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) - : int = 1 ---- For an even nicer output `QCheck_runner.run_tests` also accepts an optional parameter `~verbose:true`. === Mirrors and Trees `QCheck` provides many useful combinators to write generators, especially for recursive types, algebraic types, and tuples. Let's see how to generate random trees: [source,OCaml] ---- type tree = Leaf of int | Node of tree * tree let leaf x = Leaf x let node x y = Node (x,y) let tree_gen = QCheck.Gen.(sized @@ fix (fun self n -> match n with | 0 -> map leaf nat | n -> frequency [1, map leaf nat; 2, map2 node (self (n/2)) (self (n/2))] ));; (* generate a few trees, just to check what they look like: *) QCheck.Gen.generate ~n:20 tree_gen;; let arbitrary_tree = let open QCheck.Iter in let rec print_tree = function | Leaf i -> "Leaf " ^ (string_of_int i) | Node (a,b) -> "Node (" ^ (print_tree a) ^ "," ^ (print_tree b) ^ ")" in let rec shrink_tree = function | Leaf i -> QCheck.Shrink.int i >|= leaf | Node (a,b) -> of_list [a;b] <+> (shrink_tree a >|= fun a' -> node a' b) <+> (shrink_tree b >|= fun b' -> node a b') in QCheck.make tree_gen ~print:print_tree ~shrink:shrink_tree;; ---- Here we write a generator of random trees, `tree_gen`, using the `fix` combinator. `fix` is *sized* (it is a function from `int` to a random generator; in particular for size 0 it returns only leaves). The `sized` combinator first generates a random size, and then applies its argument to this size. Other combinators include monadic abstraction, lifting functions, generation of lists, arrays, and a choice function. Then, we define `arbitrary_tree`, a `tree QCheck.arbitrary` value, which contains everything needed for testing on trees: - a random generator (mandatory), weighted with `frequency` to increase the chance of generating deep trees - a printer (optional), very useful for printing counterexamples - a *shrinker* (optional), very useful for trying to reduce big counterexamples to small counterexamples that are usually more easy to understand. The above shrinker strategy is to - reduce the integer leaves, and - substitute an internal `Node` with either of its subtrees or by splicing in a recursively shrunk subtree. A range of combinators in `QCheck.Shrink` and `QCheck.Iter` are available for building shrinking functions. We can write a failing test using this generator to see the printer and shrinker in action: [source,OCaml] ---- let rec mirror_tree (t:tree) : tree = match t with | Leaf _ -> t | Node (a,b) -> node (mirror_tree b) (mirror_tree a);; let test_buggy = QCheck.Test.make ~name:"buggy_mirror" ~count:200 arbitrary_tree (fun t -> t = mirror_tree t);; QCheck_runner.run_tests [test_buggy];; ---- This test fails with: [source,OCaml] ---- --- Failure -------------------------------------------------------------------- Test mirror_buggy failed (6 shrink steps): Node (Leaf 0,Leaf 1) ================================================================================ failure (1 tests failed, 0 tests errored, ran 1 tests) - : int = 1 ---- With the (new found) understanding that mirroring a tree changes its structure, we can formulate another property that involves sequentializing its elements in a traversal: [source,OCaml] ---- let tree_infix (t:tree): int list = let rec aux acc t = match t with | Leaf i -> i :: acc | Node (a,b) -> aux (aux acc b) a in aux [] t;; let test_mirror = QCheck.Test.make ~name:"mirror_tree" ~count:200 arbitrary_tree (fun t -> List.rev (tree_infix t) = tree_infix (mirror_tree t));; QCheck_runner.run_tests [test_mirror];; ---- === Preconditions The functions `QCheck.assume` and `QCheck.(==>)` can be used for tests with preconditions. For instance, `List.hd l :: List.tl l = l` only holds for non-empty lists. Without the precondition, the property is false and will even raise an exception in some cases. [source,OCaml] ---- let test_hd_tl = QCheck.(Test.make (list int) (fun l -> assume (l <> []); l = List.hd l :: List.tl l));; QCheck_runner.run_tests [test_hd_tl];; ---- === Long tests It is often useful to have two version of a testsuite: a short one that runs reasonably fast (so that it is effectively run each time a projet is built), and a long one that might be more exhaustive (but whose running time makes it impossible to run at each build). To that end, each test has a 'long' version. In the long version of a test, the number of tests to run is multiplied by the `~long_factor` argument of `QCheck.Test.make`. === Runners The module `QCheck_runner` defines several functions to run tests, including compatibility with `OUnit`. The easiest one is probably `run_tests`, but if you write your tests in a separate executable you can also use `run_tests_main` which parses command line arguments and exits with `0` in case of success, or an error number otherwise. === Integration within OUnit http://ounit.forge.ocamlcore.org/[OUnit] is a popular unit-testing framework for OCaml. QCheck provides a sub-library `qcheck-ounit` with some helpers, in `QCheck_ounit`, to convert its random tests into OUnit tests that can be part of a wider test-suite. [source,OCaml] ---- let passing = QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" QCheck.(list small_nat) (fun l -> List.rev (List.rev l) = l);; let failing = QCheck.Test.make ~count:10 ~name:"fail_sort_id" QCheck.(list small_nat) (fun l -> l = List.sort compare l);; let _ = let open OUnit in run_test_tt_main ("tests" >::: List.map QCheck_ounit.to_ounit_test [passing; failing]) ---- NOTE: the package `qcheck` contains the module `QCheck_runner` which contains both custom runners and OUnit-based runners. === Integration within alcotest https://github.com/mirage/alcotest/[Alcotest] is a simple and colorful test framework for OCaml. QCheck now provides a sub-library `qcheck-alcotest` to easily integrate into an alcotest test suite: [source,OCaml] ---- let passing = QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" QCheck.(list small_int) (fun l -> List.rev (List.rev l) = l);; let failing = QCheck.Test.make ~count:10 ~name:"fail_sort_id" QCheck.(list small_int) (fun l -> l = List.sort compare l);; let () = let suite = List.map QCheck_alcotest.to_alcotest [ passing; failing] in Alcotest.run "my test" [ "suite", suite ] ---- === Integration within Rely https://reason-native.com/docs/rely/[Rely] is a Jest-inspire native reason testing framework. @reason-native/qcheck-rely is available via NPM and provides matchers for the easy use of qCheck within Rely. [source, Reason] ---- open TestFramework; open QCheckRely; let {describe} = extendDescribe(QCheckRely.Matchers.matchers); describe("qcheck-rely", ({test}) => { test("passing test", ({expect}) => { let passing = QCheck.Test.make( ~count=1000, ~name="list_rev_is_involutive", QCheck.(list(small_int)), l => List.rev(List.rev(l)) == l ); expect.ext.qCheckTest(passing); (); }); test("failing test", ({expect}) => { let failing = QCheck.Test.make( ~count=10, ~name="fail_sort_id", QCheck.(list(small_int)), l => l == List.sort(compare, l) ); expect.ext.qCheckTest(failing); (); }); }); ---- === Compatibility notes Starting with 0.9, the library is split into several components: - `qcheck-core` depends only on unix and bytes. It contains the module `QCheck` and a `QCheck_base_runner` module with our custom runners. - `qcheck-ounit` provides an integration layer for `OUnit` - `qcheck` provides a compatibility API with older versions of qcheck, using both `qcheck-core` and `qcheck-ounit`. It provides `QCheck_runner` which is similar to older versions and contains both custom and Ounit-based runners. - `qcheck-alcotest` provides an integration layer with `alcotest` Normally, for contributors, `opam pin https://github.com/c-cube/qcheck` will pin all these packages. qcheck-0.11/dune-project000066400000000000000000000000201354513211100151770ustar00rootroot00000000000000(lang dune 1.0) qcheck-0.11/example/000077500000000000000000000000001354513211100143205ustar00rootroot00000000000000qcheck-0.11/example/QCheck_runner_test.ml000066400000000000000000000113721354513211100204440ustar00rootroot00000000000000 let passing = QCheck.Test.make ~count:100 ~long_factor:100 ~name:"list_rev_is_involutive" QCheck.(list small_int) (fun l -> List.rev (List.rev l) = l);; let failing = QCheck.Test.make ~count:10 ~name:"should_fail_sort_id" QCheck.(small_list small_int) (fun l -> l = List.sort compare l);; exception Error let error = QCheck.Test.make ~count:10 ~name:"should_error_raise_exn" QCheck.int (fun _ -> raise Error) let collect = QCheck.Test.make ~count:100 ~long_factor:100 ~name:"collect_results" QCheck.(make ~collect:string_of_int (Gen.int_bound 4)) (fun _ -> true) let stats = QCheck.Test.make ~count:100 ~long_factor:100 ~name:"with_stats" QCheck.(make (Gen.int_bound 120) ~stats:[ "mod4", (fun i->i mod 4); "num", (fun i->i); ] ) (fun _ -> true) let fun1 = QCheck.Test.make ~count:100 ~long_factor:100 ~name:"FAIL_pred_map_commute" QCheck.(triple (small_list small_int) (fun1 Observable.int int) (fun1 Observable.int bool)) (fun (l,QCheck.Fun (_,f), QCheck.Fun (_,p)) -> List.filter p (List.map f l) = List.map f (List.filter p l)) let fun2 = QCheck.Test.make ~count:100 ~name:"FAIL_fun2_pred_strings" QCheck.(fun1 Observable.string bool) (fun (QCheck.Fun (_,p)) -> not (p "some random string") || p "some other string") let bad_assume_warn = QCheck.Test.make ~count:2_000 ~name:"WARN_unlikely_precond" QCheck.int (fun x -> QCheck.assume (x mod 100 = 1); true) let bad_assume_fail = QCheck.Test.make ~count:2_000 ~if_assumptions_fail:(`Fatal, 0.1) ~name:"FAIL_unlikely_precond" QCheck.int (fun x -> QCheck.assume (x mod 100 = 1); true) let int_gen = QCheck.small_nat (* int *) (* Another example (false) property *) let prop_foldleft_foldright = let open QCheck in Test.make ~name:"fold_left fold_right" ~count:1000 ~long_factor:20 (triple int_gen (list int_gen) (fun2 Observable.int Observable.int int_gen)) (fun (z,xs,f) -> let l1 = List.fold_right (Fn.apply f) xs z in let l2 = List.fold_left (Fn.apply f) z xs in if l1=l2 then true else QCheck.Test.fail_reportf "l=%s, fold_left=%s, fold_right=%s@." (QCheck.Print.(list int) xs) (QCheck.Print.int l1) (QCheck.Print.int l2) ) (* Another example (false) property *) let prop_foldleft_foldright_uncurry = let open QCheck in Test.make ~name:"fold_left fold_right uncurried" ~count:1000 ~long_factor:20 (triple (fun1 Observable.(pair int int) int_gen) int_gen (list int_gen)) (fun (f,z,xs) -> List.fold_right (fun x y -> Fn.apply f (x,y)) xs z = List.fold_left (fun x y -> Fn.apply f (x,y)) z xs) let long_shrink = let open QCheck in let listgen = list_of_size (Gen.int_range 1000 10000) int in Test.make ~name:"long_shrink" (pair listgen listgen) (fun (xs,ys) -> List.rev (xs@ys) = (List.rev xs)@(List.rev ys)) let find_ex = let open QCheck in Test.make ~name:"find_example" (2--50) (fun n -> let st = Random.State.make [| 0 |] in let f m = n < m && m < 2 * n in try let m = find_example_gen ~rand:st ~count:100_000 ~f Gen.(0 -- 1000) in f m with No_example_found _ -> false) (* test shrinking on integers *) let shrink_int = QCheck.Test.make ~count:1000 ~name:"mod3_should_fail" QCheck.int (fun i -> i mod 3 <> 0);; let stats_negs = QCheck.(Test.make ~count:5_000 ~name:"stats_neg" (add_stat ("dist",fun x -> x) small_signed_int)) (fun _ -> true) let stats_tests = let open QCheck in [ Test.make ~name:"stat_display_test_1" ~count:1000 (add_stat ("dist",fun x -> x) small_signed_int) (fun _ -> true); Test.make ~name:"stat_display_test_2" ~count:1000 (add_stat ("dist",fun x -> x) small_nat) (fun _ -> true); Test.make ~name:"stat_display_test_3" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-43643) 435434)) (fun _ -> true); Test.make ~name:"stat_display_test_4" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-40000) 40000)) (fun _ -> true); Test.make ~name:"stat_display_test_5" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-4) 4)) (fun _ -> true); Test.make ~name:"stat_display_test_6" ~count:1000 (add_stat ("dist",fun x -> x) (int_range (-4) 17)) (fun _ -> true); Test.make ~name:"stat_display_test_7" ~count:100000 (add_stat ("dist",fun x -> x) int) (fun _ -> true); ] let () = QCheck_runner.run_tests_main ([ passing; failing; error; collect; stats; fun1; fun2; prop_foldleft_foldright; prop_foldleft_foldright_uncurry; long_shrink; find_ex; shrink_int; stats_negs; bad_assume_warn; bad_assume_fail; ] @ stats_tests) qcheck-0.11/example/alcotest/000077500000000000000000000000001354513211100161365ustar00rootroot00000000000000qcheck-0.11/example/alcotest/QCheck_alcotest_test.ml000066400000000000000000000014711354513211100225660ustar00rootroot00000000000000let passing = QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" QCheck.(list small_int) (fun l -> List.rev (List.rev l) = l);; let failing = QCheck.Test.make ~count:10 ~name:"fail_sort_id" QCheck.(list small_int) (fun l -> l = List.sort compare l);; exception Error let error = QCheck.Test.make ~count:10 ~name:"error_raise_exn" QCheck.int (fun _ -> raise Error) let simple_qcheck = QCheck.Test.make ~name:"fail_check_err_message" ~count: 100 QCheck.small_int (fun _ -> QCheck.Test.fail_reportf "@[this@ will@ always@ fail@]") let () = Printexc.record_backtrace true; let module A = Alcotest in let suite = List.map QCheck_alcotest.to_alcotest [ passing; failing; error; simple_qcheck ] in A.run "my test" [ "suite", suite ] qcheck-0.11/example/alcotest/dune000066400000000000000000000001371354513211100170150ustar00rootroot00000000000000 (executable (name QCheck_alcotest_test) (libraries qcheck-core qcheck-alcotest alcotest)) qcheck-0.11/example/dune000066400000000000000000000001041354513211100151710ustar00rootroot00000000000000 (executables (names QCheck_runner_test) (libraries qcheck) ) qcheck-0.11/example/ounit/000077500000000000000000000000001354513211100154565ustar00rootroot00000000000000qcheck-0.11/example/ounit/QCheck_ounit_test.ml000066400000000000000000000014241354513211100214240ustar00rootroot00000000000000let passing = QCheck.Test.make ~count:1000 ~name:"list_rev_is_involutive" QCheck.(list small_int) (fun l -> List.rev (List.rev l) = l);; let failing = QCheck.Test.make ~count:10 ~name:"fail_sort_id" QCheck.(list small_int) (fun l -> l = List.sort compare l);; exception Error let error = QCheck.Test.make ~count:10 ~name:"error_raise_exn" QCheck.int (fun _ -> raise Error) let simple_qcheck = QCheck.Test.make ~name:"fail_check_err_message" ~count: 100 QCheck.small_int (fun _ -> QCheck.Test.fail_reportf "@[this@ will@ always@ fail@]") let () = Printexc.record_backtrace true; let open OUnit2 in run_test_tt_main ("tests" >::: List.map QCheck_ounit.to_ounit2_test [passing; failing; error; simple_qcheck]) qcheck-0.11/example/ounit/QCheck_test.ml000066400000000000000000000017661354513211100202170ustar00rootroot00000000000000let (|>) x f = f x module Q = QCheck let passing = Q.Test.make ~count:1000 ~long_factor:2 ~name:"list_rev_is_involutive" Q.(list small_int) (fun l -> List.rev (List.rev l) = l);; let failing = Q.Test.make ~count:10 ~name:"should_fail_sort_id" Q.(small_list small_int) (fun l -> l = List.sort compare l);; exception Error let error = Q.Test.make ~count:10 ~name:"should_error_raise_exn" Q.int (fun _ -> raise Error) open OUnit let regression_23 = "issue_23" >:: (fun () -> let l = Q.Gen.(generate ~n:100_000 char) in OUnit.assert_bool "must contain '\255'" (List.exists (fun c->c = '\255') l) ) let regressions = [ regression_23 ] let others = [ passing; failing; error; ] |> List.map (fun t -> QCheck_ounit.to_ounit_test t) let suite = "tests" >::: (regressions @ others) let () = try exit (QCheck_ounit.run suite) with Arg.Bad msg -> print_endline msg; exit 1 | Arg.Help msg -> print_endline msg; exit 0 qcheck-0.11/example/ounit/dune000066400000000000000000000001421354513211100163310ustar00rootroot00000000000000 (executables (names QCheck_ounit_test QCheck_test) (libraries qcheck oUnit qcheck-ounit) ) qcheck-0.11/qcheck-alcotest.opam000066400000000000000000000013251354513211100166160ustar00rootroot00000000000000opam-version: "2.0" maintainer: "simon.cruanes.2007@m4x.org" author: [ "Simon Cruanes " ] homepage: "https://github.com/c-cube/qcheck/" synopsis: "Alcotest backend for qcheck" doc: ["http://c-cube.github.io/qcheck/"] version: "0.11" tags: [ "test" "quickcheck" "qcheck" "alcotest" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ "dune" "base-bytes" "base-unix" "qcheck-core" { = version } "alcotest" "odoc" {with-doc} "ocaml" {>= "4.03.0"} ] dev-repo: "git+https://github.com/c-cube/qcheck.git" bug-reports: "https://github.com/c-cube/qcheck/issues" qcheck-0.11/qcheck-core.opam000066400000000000000000000012741354513211100157330ustar00rootroot00000000000000opam-version: "2.0" maintainer: "simon.cruanes.2007@m4x.org" author: [ "Simon Cruanes " ] homepage: "https://github.com/c-cube/qcheck/" synopsis: "Core qcheck library" doc: ["http://c-cube.github.io/qcheck/"] version: "0.11" tags: [ "test" "property" "quickcheck" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ "dune" "base-bytes" "base-unix" "odoc" {with-doc} "ocaml" {>= "4.03.0"} ] dev-repo: "git+https://github.com/c-cube/qcheck.git" bug-reports: "https://github.com/c-cube/qcheck/issues" conflicts: [ "ounit" { < "2.0" } ] qcheck-0.11/qcheck-ounit.opam000066400000000000000000000013161354513211100161360ustar00rootroot00000000000000opam-version: "2.0" maintainer: "simon.cruanes.2007@m4x.org" author: [ "Simon Cruanes " ] homepage: "https://github.com/c-cube/qcheck/" doc: ["http://c-cube.github.io/qcheck/"] synopsis: "OUnit backend for qcheck" version: "0.11" tags: [ "qcheck" "quickcheck" "ounit" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ "dune" "base-bytes" "base-unix" "qcheck-core" { = version } "ounit" {>= "2.0"} "odoc" {with-doc} "ocaml" {>= "4.03.0"} ] dev-repo: "git+https://github.com/c-cube/qcheck.git" bug-reports: "https://github.com/c-cube/qcheck/issues" qcheck-0.11/qcheck.opam000066400000000000000000000014061354513211100150020ustar00rootroot00000000000000opam-version: "2.0" maintainer: "simon.cruanes.2007@m4x.org" author: [ "Simon Cruanes " ] synopsis: "Compatibility package for qcheck" homepage: "https://github.com/c-cube/qcheck/" doc: ["http://c-cube.github.io/qcheck/"] version: "0.11" tags: [ "test" "property" "quickcheck" ] build: [ ["dune" "build" "-p" name "-j" jobs] ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] depends: [ "dune" "base-bytes" "base-unix" "qcheck-core" { = version } "qcheck-ounit" { = version } "odoc" {with-doc} "ocaml" {>= "4.03.0"} ] dev-repo: "git+https://github.com/c-cube/qcheck.git" bug-reports: "https://github.com/c-cube/qcheck/issues" conflicts: [ "ounit" { < "2.0" } ] qcheck-0.11/src/000077500000000000000000000000001354513211100134545ustar00rootroot00000000000000qcheck-0.11/src/QCheck_runner.ml000066400000000000000000000000611354513211100165320ustar00rootroot00000000000000 include QCheck_base_runner include QCheck_ounit qcheck-0.11/src/alcotest/000077500000000000000000000000001354513211100152725ustar00rootroot00000000000000qcheck-0.11/src/alcotest/QCheck_alcotest.ml000066400000000000000000000017641354513211100206700ustar00rootroot00000000000000 module Q = QCheck module T = QCheck.Test module Raw = QCheck_base_runner.Raw let seed_ = lazy ( let s = try int_of_string @@ Sys.getenv "QCHECK_SEED" with _ -> Random.self_init(); Random.int 1_000_000_000 in Printf.printf "qcheck random seed: %d\n%!" s; s ) let default_rand () = (* random seed, for repeatability of tests *) Random.State.make [| Lazy.force seed_ |] let verbose_ = lazy ( match Sys.getenv "QCHECK_VERBOSE" with | "1" | "true" -> true | _ -> false | exception Not_found -> false ) let long_ = lazy ( match Sys.getenv "QCHECK_LONG" with | "1" | "true" -> true | _ -> false | exception Not_found -> false ) let to_alcotest ?(verbose=Lazy.force verbose_) ?(long=Lazy.force long_) ?(rand=default_rand()) (t:T.t) = let T.Test cell = t in let print = Raw.print_std in let run() = T.check_cell_exn cell ~long ~rand ~call:(Raw.callback ~verbose ~print_res:true ~print) in let name = T.get_name cell in name, `Slow, run qcheck-0.11/src/alcotest/QCheck_alcotest.mli000066400000000000000000000012671354513211100210370ustar00rootroot00000000000000 (** {1 Alcotest backend for QCheck} We use environment variables for controlling QCheck here, since alcotest doesn't seem to provide a lot of flexibility. - [QCHECK_VERBOSE] if "1" or "true", will make tests verbose - [QCHECK_SEED] if an integer, will fix the seed - [QCHECK_LONG] is present, will trigger long tests @since 0.9 *) val to_alcotest : ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> QCheck.Test.t -> unit Alcotest.test_case (** Convert a qcheck test into an alcotest test @param verbose used to print information on stdout (default: [verbose()]) @param rand the random generator to use (default: [random_state ()]) @since 0.9 *) qcheck-0.11/src/alcotest/dune000066400000000000000000000003321354513211100161460ustar00rootroot00000000000000 (library (name qcheck_alcotest) (public_name qcheck-alcotest) (wrapped false) (libraries unix bytes qcheck-core qcheck-core.runner alcotest) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) ) qcheck-0.11/src/core/000077500000000000000000000000001354513211100144045ustar00rootroot00000000000000qcheck-0.11/src/core/QCheck.ml000066400000000000000000001470071354513211100161050ustar00rootroot00000000000000 (* QCheck: Random testing for OCaml copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard all rights reserved. *) (** {1 Quickcheck inspired property-based testing} *) open Printf module RS = Random.State let (|>) x f = f x let rec foldn ~f ~init:acc i = if i = 0 then acc else foldn ~f ~init:(f acc i) (i-1) let _is_some = function Some _ -> true | None -> false let _opt_map_or ~d ~f = function | None -> d | Some x -> f x let _opt_or a b = match a with | None -> b | Some x -> x let _opt_map ~f = function | None -> None | Some x -> Some (f x) let _opt_map_2 ~f a b = match a, b with | Some x, Some y -> Some (f x y) | _ -> None let _opt_map_3 ~f a b c = match a, b, c with | Some x, Some y, Some z -> Some (f x y z) | _ -> None let _opt_map_4 ~f a b c d = match a, b, c, d with | Some x, Some y, Some z, Some w -> Some (f x y z w) | _ -> None let _opt_sum a b = match a, b with | Some _, _ -> a | None, _ -> b let sum_int = List.fold_left (+) 0 exception FailedPrecondition (* raised if precondition is false *) exception No_example_found of string (* raised if an example failed to be found *) let assume b = if not b then raise FailedPrecondition let assume_fail () = raise FailedPrecondition let (==>) b1 b2 = if b1 then b2 else raise FailedPrecondition module Gen = struct type 'a t = RS.t -> 'a type 'a sized = int -> Random.State.t -> 'a let return x _st = x let pure = return let (>>=) gen f st = f (gen st) st let (<*>) f x st = f st (x st) let map f x st = f (x st) let map2 f x y st = f (x st) (y st) let map3 f x y z st = f (x st) (y st) (z st) let map_keep_input f gen st = let x = gen st in x, f x let (>|=) x f = map f x let oneof l st = List.nth l (Random.State.int st (List.length l)) st let oneofl xs st = List.nth xs (Random.State.int st (List.length xs)) let oneofa xs st = Array.get xs (Random.State.int st (Array.length xs)) let frequencyl l st = let sums = sum_int (List.map fst l) in let i = Random.State.int st sums in let rec aux acc = function | ((x,g)::xs) -> if i < acc+x then g else aux (acc+x) xs | _ -> failwith "frequency" in aux 0 l let frequencya a = frequencyl (Array.to_list a) let frequency l st = frequencyl l st st let small_nat st = let p = RS.float st 1. in if p < 0.75 then RS.int st 10 else RS.int st 100 (* natural number generator *) let nat st = let p = RS.float st 1. in if p < 0.5 then RS.int st 10 else if p < 0.75 then RS.int st 100 else if p < 0.95 then RS.int st 1_000 else RS.int st 10_000 let big_nat st = let p = RS.float st 1. in if p < 0.75 then nat st else RS.int st 1_000_000 let unit _st = () let bool st = RS.bool st let float st = exp (RS.float st 15. *. (if RS.float st 1. < 0.5 then 1. else -1.)) *. (if RS.float st 1. < 0.5 then 1. else -1.) let pfloat st = abs_float (float st) let nfloat st = -.(pfloat st) let float_bound_inclusive bound st = RS.float st bound let float_bound_exclusive bound st = match bound with | 0. -> raise (Invalid_argument "Gen.float_bound_exclusive") | b_pos when bound > 0. -> RS.float st (b_pos -. epsilon_float) | b_neg -> RS.float st (b_neg +. epsilon_float) let float_range low high = if high < low || high -. low > max_float then invalid_arg "Gen.float_range"; fun st -> low +. (float_bound_inclusive (high -. low) st) let (--.) = float_range let neg_int st = -(nat st) let opt f st = let p = RS.float st 1. in if p < 0.15 then None else Some (f st) (* Uniform random int generator *) let pint = if Sys.word_size = 32 then fun st -> RS.bits st else (* word size = 64 *) fun st -> RS.bits st (* Bottom 30 bits *) lor (RS.bits st lsl 30) (* Middle 30 bits *) lor ((RS.bits st land 3) lsl 60) (* Top 2 bits *) (* top bit = 0 *) let int st = if RS.bool st then - (pint st) - 1 else pint st let int_bound n = if n < 0 then invalid_arg "Gen.int_bound"; if n <= (1 lsl 30) - 2 then fun st -> Random.State.int st (n + 1) else fun st -> let r = pint st in r mod (n + 1) let int_range a b = if b < a then invalid_arg "Gen.int_range"; fun st -> a + (int_bound (b-a) st) let (--) = int_range (* NOTE: we keep this alias to not break code that uses [small_int] for sizes of strings, arrays, etc. *) let small_int = small_nat let small_signed_int st = if bool st then small_nat st else - (small_nat st) let random_binary_string st length = (* 0b011101... *) let s = Bytes.create (length + 2) in Bytes.set s 0 '0'; Bytes.set s 1 'b'; for i = 0 to length - 1 do Bytes.set s (i+2) (if RS.bool st then '0' else '1') done; Bytes.unsafe_to_string s let ui32 st = Int32.of_string (random_binary_string st 32) let ui64 st = Int64.of_string (random_binary_string st 64) let list_size size gen st = foldn ~f:(fun acc _ -> (gen st)::acc) ~init:[] (size st) let list gen st = list_size nat gen st let list_repeat n g = list_size (return n) g let array_size size gen st = Array.init (size st) (fun _ -> gen st) let array gen st = array_size nat gen st let array_repeat n g = array_size (return n) g let shuffle_a a st = for i = Array.length a-1 downto 1 do let j = Random.State.int st (i+1) in let tmp = a.(i) in a.(i) <- a.(j); a.(j) <- tmp; done let shuffle_l l st = let a = Array.of_list l in shuffle_a a st; Array.to_list a let shuffle_w_l l st = let sample (w, v) = let fl_w = float_of_int w in (float_bound_inclusive 1. st ** (1. /. fl_w), v) in let samples = List.rev_map sample l in List.sort (fun (w1, _) (w2, _) -> compare w1 w2) samples |> List.rev_map snd let pair g1 g2 st = (g1 st, g2 st) let triple g1 g2 g3 st = (g1 st, g2 st, g3 st) let quad g1 g2 g3 g4 st = (g1 st, g2 st, g3 st, g4 st) let char st = char_of_int (RS.int st 256) let printable_chars = let l = 126-32+1 in let s = Bytes.create l in for i = 0 to l-2 do Bytes.set s i (char_of_int (32+i)) done; Bytes.set s (l-1) '\n'; Bytes.unsafe_to_string s let printable st = printable_chars.[RS.int st (String.length printable_chars)] let numeral st = char_of_int (48 + RS.int st 10) let string_size ?(gen = char) size st = let s = Bytes.create (size st) in for i = 0 to Bytes.length s - 1 do Bytes.set s i (gen st) done; Bytes.unsafe_to_string s let string ?gen st = string_size ?gen nat st let string_of gen = string_size ~gen nat let string_readable = string_size ~gen:char nat let small_string ?gen st = string_size ?gen small_nat st let small_list gen = list_size small_nat gen let small_array gen = array_size small_nat gen let join g st = (g st) st (* corner cases *) let graft_corners gen corners () = let cors = ref corners in fun st -> match !cors with [] -> gen st | e::l -> cors := l; e let int_pos_corners = [0;1;2;max_int] let int_corners = int_pos_corners @ [min_int] let nng_corners () = graft_corners nat int_pos_corners () (* sized, fix *) let sized_size s f st = f (s st) st let sized f = sized_size nat f let fix f = let rec f' n st = f f' n st in f' let generate ?(rand=Random.State.make_self_init()) ~n g = list_repeat n g rand let generate1 ?(rand=Random.State.make_self_init()) g = g rand end module Print = struct type 'a t = 'a -> string let unit _ = "()" let int = string_of_int let bool = string_of_bool let float = string_of_float let string s = s let char c = String.make 1 c let option f = function | None -> "None" | Some x -> "Some (" ^ f x ^ ")" let pair a b (x,y) = Printf.sprintf "(%s, %s)" (a x) (b y) let triple a b c (x,y,z) = Printf.sprintf "(%s, %s, %s)" (a x) (b y) (c z) let quad a b c d (x,y,z,w) = Printf.sprintf "(%s, %s, %s, %s)" (a x) (b y) (c z) (d w) let list pp l = let b = Buffer.create 25 in Buffer.add_char b '['; List.iteri (fun i x -> if i > 0 then Buffer.add_string b "; "; Buffer.add_string b (pp x)) l; Buffer.add_char b ']'; Buffer.contents b let array pp a = let b = Buffer.create 25 in Buffer.add_string b "[|"; Array.iteri (fun i x -> if i > 0 then Buffer.add_string b "; "; Buffer.add_string b (pp x)) a; Buffer.add_string b "|]"; Buffer.contents b let comap f p x = p (f x) end module Iter = struct type 'a t = ('a -> unit) -> unit let empty _ = () let return x yield = yield x let (<*>) a b yield = a (fun f -> b (fun x -> yield (f x))) let (>>=) a f yield = a (fun x -> f x yield) let map f a yield = a (fun x -> yield (f x)) let map2 f a b yield = a (fun x -> b (fun y -> yield (f x y))) let (>|=) a f = map f a let append a b yield = a yield; b yield let append_l l yield = List.iter (fun s->s yield) l let flatten s yield = s (fun sub -> sub yield) let filter f s yield = s (fun x -> if f x then yield x) let (<+>) = append let of_list l yield = List.iter yield l let of_array a yield = Array.iter yield a let pair a b yield = a (fun x -> b(fun y -> yield (x,y))) let triple a b c yield = a (fun x -> b (fun y -> c (fun z -> yield (x,y,z)))) let quad a b c d yield = a (fun x -> b (fun y -> c (fun z -> d (fun w -> yield (x,y,z,w))))) exception IterExit let find_map p iter = let r = ref None in (try iter (fun x -> match p x with Some _ as y -> r := y; raise IterExit | None -> ()) with IterExit -> () ); !r let find p iter = find_map (fun x->if p x then Some x else None) iter end module Shrink = struct type 'a t = 'a -> 'a Iter.t let nil _ = Iter.empty let unit = nil (* balanced shrinker for integers (non-exhaustive) *) let int x yield = let y = ref x in (* try some divisors *) while !y < -2 || !y >2 do y := !y / 2; yield (x - !y); done; (* fast path *) if x>0 then yield (x-1); if x<0 then yield (x+1); () (* aggressive shrinker for integers, get from 0 to x, by dichotomy or just enumerating smaller values *) let int_aggressive x yield = let y = ref x in while !y < -2 || !y >2 do y := !y / 2; yield (x - !y); done; (* fast path *) if x>0 then for i=x-1 downto 0 do yield i done; if x<0 then for i=x+1 to 0 do yield i done let filter f shrink x = Iter.filter f (shrink x) let char c yield = if Char.code c > 0 then yield (Char.chr (Char.code c-1)) let option s x = match x with | None -> Iter.empty | Some x -> Iter.(return None <+> map (fun y->Some y) (s x)) let string s yield = for i =0 to String.length s-1 do let s' = Bytes.init (String.length s-1) (fun j -> if j 0 do for i=0 to n - !chunk_size do (* remove elements in [i .. i+!chunk_size] *) let a' = Array.init (n - !chunk_size) (fun j -> if j< i then a.(j) else a.(j + !chunk_size)) in yield a' done; chunk_size := !chunk_size / 2; done; match shrink with | None -> () | Some f -> (* try to shrink each element of the array *) for i = 0 to Array.length a - 1 do f a.(i) (fun x -> let b = Array.copy a in b.(i) <- x; yield b ) done let list_spine l yield = let n = List.length l in let chunk_size = ref (n/2) in (* push the [n] first elements of [l] into [q], return the rest of the list *) let rec fill_queue n l q = match n,l with | 0, _ -> l | _, x::xs -> Queue.push x q; fill_queue (n-1) xs q | _, _ -> assert false in (* remove elements from the list, by chunks of size [chunk_size] (bigger chunks first) *) while !chunk_size > 0 do let q = Queue.create () in let l' = fill_queue !chunk_size l q in (* remove [chunk_size] elements in queue *) let rec pos_loop rev_prefix suffix = yield (List.rev_append rev_prefix suffix); match suffix with | [] -> () | x::xs -> Queue.push x q; let y = Queue.pop q in (pos_loop [@tailcall]) (y::rev_prefix) xs in pos_loop [] l'; chunk_size := !chunk_size / 2; done let list_elems shrink l yield = (* try to shrink each element of the list *) let rec elem_loop rev_prefix suffix = match suffix with | [] -> () | x::xs -> shrink x (fun x' -> yield (List.rev_append rev_prefix (x'::xs))); elem_loop (x::rev_prefix) xs in elem_loop [] l let list ?shrink l yield = list_spine l yield; match shrink with | None -> () | Some shrink -> list_elems shrink l yield let pair a b (x,y) yield = a x (fun x' -> yield (x',y)); b y (fun y' -> yield (x,y')) let triple a b c (x,y,z) yield = a x (fun x' -> yield (x',y,z)); b y (fun y' -> yield (x,y',z)); c z (fun z' -> yield (x,y,z')) let quad a b c d (x,y,z,w) yield = a x (fun x' -> yield (x',y,z,w)); b y (fun y' -> yield (x,y',z,w)); c z (fun z' -> yield (x,y,z',w)); d w (fun w' -> yield (x,y,z,w')) end (** {2 Observe Values} *) module Observable = struct (** An observable is a (random) predicate on ['a] *) type -'a t = { print: 'a Print.t; eq: ('a -> 'a -> bool); hash: ('a -> int); } let hash o x = o.hash x let equal o x y = o.eq x y let print o x = o.print x let make ?(eq=(=)) ?(hash=Hashtbl.hash) print = {print; eq; hash; } module H = struct let combine a b = Hashtbl.seeded_hash a b let combine_f f s x = Hashtbl.seeded_hash s (f x) let int i = i land max_int let bool b = if b then 1 else 2 let char x = Char.code x let string (x:string) = Hashtbl.hash x let opt f = function | None -> 42 | Some x -> combine 43 (f x) let list f l = List.fold_left (combine_f f) 0x42 l let array f l = Array.fold_left (combine_f f) 0x42 l let pair f g (x,y) = combine (f x) (g y) end module Eq = struct type 'a t = 'a -> 'a -> bool let int : int t = (=) let string : string t = (=) let bool : bool t = (=) let float : float t = (=) let unit () () = true let char : char t = (=) let rec list f l1 l2 = match l1, l2 with | [], [] -> true | [], _ | _, [] -> false | x1::l1', x2::l2' -> f x1 x2 && list f l1' l2' let array eq a b = let rec aux i = if i = Array.length a then true else eq a.(i) b.(i) && aux (i+1) in Array.length a = Array.length b && aux 0 let option f o1 o2 = match o1, o2 with | None, None -> true | Some _, None | None, Some _ -> false | Some x, Some y -> f x y let pair f g (x1,y1)(x2,y2) = f x1 x2 && g y1 y2 end let unit : unit t = make ~hash:(fun _ -> 1) ~eq:Eq.unit Print.unit let bool : bool t = make ~hash:H.bool ~eq:Eq.bool Print.bool let int : int t = make ~hash:H.int ~eq:Eq.int Print.int let float : float t = make ~eq:Eq.float Print.float let string = make ~hash:H.string ~eq:Eq.string Print.string let char = make ~hash:H.char ~eq:Eq.char Print.char let option p = make ~hash:(H.opt p.hash) ~eq:(Eq.option p.eq) (Print.option p.print) let array p = make ~hash:(H.array p.hash) ~eq:(Eq.array p.eq) (Print.array p.print) let list p = make ~hash:(H.list p.hash) ~eq:(Eq.list p.eq) (Print.list p.print) let map f p = make ~hash:(fun x -> p.hash (f x)) ~eq:(fun x y -> p.eq (f x)(f y)) (fun x -> p.print (f x)) let pair a b = make ~hash:(H.pair a.hash b.hash) ~eq:(Eq.pair a.eq b.eq) (Print.pair a.print b.print) let triple a b c = map (fun (x,y,z) -> x,(y,z)) (pair a (pair b c)) let quad a b c d = map (fun (x,y,z,u) -> x,(y,z,u)) (pair a (triple b c d)) end type 'a stat = string * ('a -> int) (** A statistic on a distribution of values of type ['a] *) type 'a arbitrary = { gen: 'a Gen.t; print: ('a -> string) option; (** print values *) small: ('a -> int) option; (** size of example *) shrink: ('a -> 'a Iter.t) option; (** shrink to smaller examples *) collect: ('a -> string) option; (** map value to tag, and group by tag *) stats: 'a stat list; (** statistics to collect and print *) } let make ?print ?small ?shrink ?collect ?(stats=[]) gen = { gen; print; small; shrink; collect; stats; } let set_small f o = {o with small=Some f} let set_print f o = {o with print=Some f} let set_shrink f o = {o with shrink=Some f} let set_collect f o = {o with collect=Some f} let set_stats s o = {o with stats=s} let add_stat s o = {o with stats=s :: o.stats} let set_gen g o = {o with gen=g} let add_shrink_invariant f o = match o.shrink with | None -> o | Some shr -> {o with shrink=Some (Shrink.filter f shr)} let gen o = o.gen let small1 _ = 1 let make_scalar ?print ?collect gen = make ~shrink:Shrink.nil ~small:small1 ?print ?collect gen let make_int ?collect gen = make ~shrink:Shrink.int ~small:small1 ~print:Print.int ?collect gen let adapt_ o gen = make ?print:o.print ?small:o.small ?shrink:o.shrink ?collect:o.collect gen let choose l = match l with | [] -> raise (Invalid_argument "quickcheck.choose") | l -> let a = Array.of_list l in adapt_ a.(0) (fun st -> let arb = a.(RS.int st (Array.length a)) in arb.gen st) let unit : unit arbitrary = make ~small:small1 ~shrink:Shrink.nil ~print:(fun _ -> "()") Gen.unit let bool = make_scalar ~print:string_of_bool Gen.bool let float = make_scalar ~print:string_of_float Gen.float let pos_float = make_scalar ~print:string_of_float Gen.pfloat let neg_float = make_scalar ~print:string_of_float Gen.nfloat let float_bound_inclusive bound = make_scalar ~print:string_of_float (Gen.float_bound_inclusive bound) let float_bound_exclusive bound = make_scalar ~print:string_of_float (Gen.float_bound_exclusive bound) let float_range low high = make_scalar ~print:string_of_float (Gen.float_range low high) let int = make_int Gen.int let int_bound n = make_int (Gen.int_bound n) let int_range a b = make_int (Gen.int_range a b) let (--) = int_range let pos_int = make_int Gen.pint let small_int = make_int Gen.small_int let small_nat = make_int Gen.small_nat let small_signed_int = make_int Gen.small_signed_int let small_int_corners () = make_int (Gen.nng_corners ()) let neg_int = make_int Gen.neg_int let int32 = make_scalar ~print:(fun i -> Int32.to_string i ^ "l") Gen.ui32 let int64 = make_scalar ~print:(fun i -> Int64.to_string i ^ "L") Gen.ui64 let char = make_scalar ~print:(sprintf "%C") Gen.char let printable_char = make_scalar ~print:(sprintf "%C") Gen.printable let numeral_char = make_scalar ~print:(sprintf "%C") Gen.numeral let string_gen_of_size size gen = make ~shrink:Shrink.string ~small:String.length ~print:(sprintf "%S") (Gen.string_size ~gen size) let string_gen gen = make ~shrink:Shrink.string ~small:String.length ~print:(sprintf "%S") (Gen.string ~gen) let string = string_gen Gen.char let string_of_size size = string_gen_of_size size Gen.char let small_string = string_gen_of_size Gen.small_nat Gen.char let printable_string = string_gen Gen.printable let printable_string_of_size size = string_gen_of_size size Gen.printable let small_printable_string = string_gen_of_size Gen.small_nat Gen.printable let numeral_string = string_gen Gen.numeral let numeral_string_of_size size = string_gen_of_size size Gen.numeral let list_sum_ f l = List.fold_left (fun acc x-> f x+acc) 0 l let mk_list a gen = (* small sums sub-sizes if present, otherwise just length *) let small = _opt_map_or a.small ~f:list_sum_ ~d:List.length in let print = _opt_map a.print ~f:Print.list in make ~small ~shrink:(Shrink.list ?shrink:a.shrink) ?print gen let list a = mk_list a (Gen.list a.gen) let list_of_size size a = mk_list a (Gen.list_size size a.gen) let small_list a = mk_list a (Gen.small_list a.gen) let array_sum_ f a = Array.fold_left (fun acc x -> f x+acc) 0 a let array a = let small = _opt_map_or ~d:Array.length ~f:array_sum_ a.small in make ~small ~shrink:(Shrink.array ?shrink:a.shrink) ?print:(_opt_map ~f:Print.array a.print) (Gen.array a.gen) let array_of_size size a = let small = _opt_map_or ~d:Array.length ~f:array_sum_ a.small in make ~small ~shrink:(Shrink.array ?shrink:a.shrink) ?print:(_opt_map ~f:Print.array a.print) (Gen.array_size size a.gen) let pair a b = make ?small:(_opt_map_2 ~f:(fun f g (x,y) -> f x+g y) a.small b.small) ?print:(_opt_map_2 ~f:Print.pair a.print b.print) ~shrink:(Shrink.pair (_opt_or a.shrink Shrink.nil) (_opt_or b.shrink Shrink.nil)) (Gen.pair a.gen b.gen) let triple a b c = make ?small:(_opt_map_3 ~f:(fun f g h (x,y,z) -> f x+g y+h z) a.small b.small c.small) ?print:(_opt_map_3 ~f:Print.triple a.print b.print c.print) ~shrink:(Shrink.triple (_opt_or a.shrink Shrink.nil) (_opt_or b.shrink Shrink.nil) (_opt_or c.shrink Shrink.nil)) (Gen.triple a.gen b.gen c.gen) let quad a b c d = make ?small:(_opt_map_4 ~f:(fun f g h i (x,y,z,w) -> f x+g y+h z+i w) a.small b.small c.small d.small) ?print:(_opt_map_4 ~f:Print.quad a.print b.print c.print d.print) ~shrink:(Shrink.quad (_opt_or a.shrink Shrink.nil) (_opt_or b.shrink Shrink.nil) (_opt_or c.shrink Shrink.nil) (_opt_or d.shrink Shrink.nil)) (Gen.quad a.gen b.gen c.gen d.gen) let option a = let g = Gen.opt a.gen and shrink = _opt_map a.shrink ~f:Shrink.option and small = _opt_map_or a.small ~d:(function None -> 0 | Some _ -> 1) ~f:(fun f o -> match o with None -> 0 | Some x -> f x) in make ~small ?shrink ?print:(_opt_map ~f:Print.option a.print) g let map ?rev f a = make ?print:(_opt_map_2 rev a.print ~f:(fun r p x -> p (r x))) ?small:(_opt_map_2 rev a.small ~f:(fun r s x -> s (r x))) ?shrink:(_opt_map_2 rev a.shrink ~f:(fun r g x -> Iter.(g (r x) >|= f))) ?collect:(_opt_map_2 rev a.collect ~f:(fun r f x -> f (r x))) (fun st -> f (a.gen st)) let fun1_unsafe : 'a arbitrary -> 'b arbitrary -> ('a -> 'b) arbitrary = fun a1 a2 -> let magic_object = Obj.magic (object end) in let gen : ('a -> 'b) Gen.t = fun st -> let h = Hashtbl.create 10 in fun x -> if x == magic_object then Obj.magic h else try Hashtbl.find h x with Not_found -> let b = a2.gen st in Hashtbl.add h x b; b in let pp : (('a -> 'b) -> string) option = _opt_map_2 a1.print a2.print ~f:(fun p1 p2 f -> let h : ('a, 'b) Hashtbl.t = Obj.magic (f magic_object) in let b = Buffer.create 20 in Hashtbl.iter (fun key value -> Printf.bprintf b "%s -> %s; " (p1 key) (p2 value)) h; "{" ^ Buffer.contents b ^ "}" ) in make ?print:pp gen let fun2_unsafe gp1 gp2 gp3 = fun1_unsafe gp1 (fun1_unsafe gp2 gp3) module Poly_tbl : sig type ('a, 'b) t val create: 'a Observable.t -> 'b arbitrary -> int -> ('a, 'b) t Gen.t val get : ('a, 'b) t -> 'a -> 'b option val size : ('b -> int) -> (_, 'b) t -> int val shrink1 : ('a, 'b) t Shrink.t val shrink2 : 'b Shrink.t -> ('a, 'b) t Shrink.t val print : (_,_) t Print.t end = struct type ('a, 'b) t = { get : 'a -> 'b option; p_size: ('b->int) -> int; p_shrink1: ('a, 'b) t Iter.t; p_shrink2: 'b Shrink.t -> ('a, 'b) t Iter.t; p_print: unit -> string; } let create (type k)(type v) k v size st : (k,v) t = let module T = Hashtbl.Make(struct type t = k let equal = k.Observable.eq let hash = k.Observable.hash end) in let tbl_to_list tbl = T.fold (fun k v l -> (k,v)::l) tbl [] and tbl_of_list l = let tbl = T.create (max (List.length l) 8) in List.iter (fun (k,v) -> T.add tbl k v) l; tbl in (* make a table @param extend if true, extend table on the fly *) let rec make ~extend tbl = { get=(fun x -> try Some (T.find tbl x) with Not_found -> if extend then ( let v = v.gen st in T.add tbl x v; Some v ) else None); p_print=(fun () -> match v.print with | None -> "" | Some pp_v -> let b = Buffer.create 64 in T.iter (fun key value -> Printf.bprintf b "%s -> %s; " (k.Observable.print key) (pp_v value)) tbl; Buffer.contents b); p_shrink1=(fun yield -> Shrink.list (tbl_to_list tbl) (fun l -> yield (make ~extend:false (tbl_of_list l))) ); p_shrink2=(fun shrink_val yield -> (* shrink bindings one by one *) T.iter (fun x y -> shrink_val y (fun y' -> let tbl' = T.copy tbl in T.replace tbl' x y'; yield (make ~extend:false tbl'))) tbl); p_size=(fun size_v -> T.fold (fun _ v n -> n + size_v v) tbl 0); } in make ~extend:true (T.create size) let get t x = t.get x let shrink1 t = t.p_shrink1 let shrink2 p t = t.p_shrink2 p let print t = t.p_print () let size p t = t.p_size p end (** Internal representation of functions *) type ('a, 'b) fun_repr_tbl = { fun_tbl: ('a, 'b) Poly_tbl.t; fun_arb: 'b arbitrary; fun_default: 'b; } type 'f fun_repr = | Fun_tbl : ('a, 'ret) fun_repr_tbl -> ('a -> 'ret) fun_repr | Fun_map : ('f1 -> 'f2) * 'f1 fun_repr -> 'f2 fun_repr type _ fun_ = | Fun : 'f fun_repr * 'f -> 'f fun_ (** Reifying functions *) module Fn = struct type 'a t = 'a fun_ let apply (Fun (_,f)) = f let make_ (r:_ fun_repr) : _ fun_ = let rec call : type f. f fun_repr -> f = fun r -> match r with | Fun_tbl r -> begin fun x -> match Poly_tbl.get r.fun_tbl x with | None -> r.fun_default | Some y -> y end | Fun_map (g, r') -> g (call r') in Fun (r, call r) let mk_repr tbl arb def = Fun_tbl { fun_tbl=tbl; fun_arb=arb; fun_default=def; } let map_repr f repr = Fun_map (f,repr) let map_fun f (Fun (repr,_)) = make_ (map_repr f repr) let shrink_rep (r: _ fun_repr): _ Iter.t = let open Iter in let rec aux : type f. f fun_repr Shrink.t = function | Fun_tbl {fun_arb=a; fun_tbl=tbl; fun_default=def} -> let sh_v = match a.shrink with None -> Shrink.nil | Some s->s in (Poly_tbl.shrink1 tbl >|= fun tbl' -> mk_repr tbl' a def) <+> (sh_v def >|= fun def' -> mk_repr tbl a def') <+> (Poly_tbl.shrink2 sh_v tbl >|= fun tbl' -> mk_repr tbl' a def) | Fun_map (g, r') -> aux r' >|= map_repr g in aux r let shrink (Fun (rep,_)) = let open Iter in shrink_rep rep >|= make_ let rec size_rep : type f. f fun_repr -> int = function | Fun_map (_, r') -> size_rep r' | Fun_tbl r -> let size_v x = match r.fun_arb.small with None -> 0 | Some f -> f x in Poly_tbl.size size_v r.fun_tbl + size_v r.fun_default let size (Fun (rep,_)) = size_rep rep let print_rep r = let buf = Buffer.create 32 in let rec aux : type f. Buffer.t -> f fun_repr -> unit = fun buf r -> match r with | Fun_map (_, r') -> aux buf r' | Fun_tbl r -> Buffer.add_string buf (Poly_tbl.print r.fun_tbl); Printf.bprintf buf "_ -> %s" (match r.fun_arb.print with | None -> "" | Some s -> s r.fun_default ); in Printf.bprintf buf "{"; aux buf r; Printf.bprintf buf "}"; Buffer.contents buf let print (Fun (rep,_)) = print_rep rep let gen_rep (a:_ Observable.t) (b:_ arbitrary): _ fun_repr Gen.t = fun st -> mk_repr (Poly_tbl.create a b 8 st) b (b.gen st) let gen a b = Gen.map make_ (gen_rep a b) end let fun1 o ret = make ~shrink:Fn.shrink ~print:Fn.print ~small:Fn.size (Fn.gen o ret) module Tuple = struct (** heterogeneous list (generic tuple) used to uncurry functions *) type 'a t = | Nil : unit t | Cons : 'a * 'b t -> ('a * 'b) t let nil = Nil let cons x tail = Cons (x,tail) type 'a obs = | O_nil : unit obs | O_cons : 'a Observable.t * 'b obs -> ('a * 'b) obs let o_nil = O_nil let o_cons x tail = O_cons (x,tail) let rec hash : type a. a obs -> a t -> int = fun o t -> match o, t with | O_nil, Nil -> 42 | O_cons (o,tail_o), Cons (x, tail) -> Observable.H.combine (Observable.hash o x) (hash tail_o tail) let rec equal : type a. a obs -> a t -> a t -> bool = fun o a b -> match o, a, b with | O_nil, Nil, Nil -> true | O_cons (o, tail_o), Cons (x1, tail1), Cons (x2,tail2) -> Observable.equal o x1 x2 && equal tail_o tail1 tail2 let print o tup = let rec aux : type a. a obs -> Buffer.t -> a t -> unit = fun o buf t -> match o, t with | O_nil, Nil -> Printf.bprintf buf "()" | O_cons (o, O_nil), Cons (x,Nil) -> Printf.bprintf buf "%s" (Observable.print o x) | O_cons (o, tail_o), Cons (x,tail) -> Printf.bprintf buf "%s, %a" (Observable.print o x) (aux tail_o) tail in let buf = Buffer.create 64 in Buffer.add_string buf "("; aux o buf tup; Buffer.add_string buf ")"; Buffer.contents buf let observable (o:'a obs) : 'a t Observable.t = Observable.make ~eq:(equal o) ~hash:(hash o) (print o) let gen (o:'a obs) (ret:'b arbitrary) : ('a t -> 'b) fun_ Gen.t = Fn.gen (observable o) ret module Infix = struct let (@::) x tail = cons x tail let (@->) o tail = o_cons o tail end include Infix end let fun_nary (o:_ Tuple.obs) ret : _ arbitrary = make ~shrink:Fn.shrink ~print:Fn.print ~small:Fn.size (Tuple.gen o ret) let fun2 o1 o2 ret = let open Tuple in map ~rev:(Fn.map_fun (fun g (Cons (x, Cons (y,Nil))) -> g x y)) (Fn.map_fun (fun g x y -> g (x @:: y @:: nil))) (fun_nary (o1 @-> o2 @-> o_nil) ret) let fun3 o1 o2 o3 ret = let open Tuple in map ~rev:(Fn.map_fun (fun g (Cons (x, Cons (y, Cons (z,Nil)))) -> g x y z)) (Fn.map_fun (fun g x y z -> g (x @:: y @:: z @:: nil))) (fun_nary (o1 @-> o2 @-> o3 @-> o_nil) ret) let fun4 o1 o2 o3 o4 ret = let open Tuple in map ~rev:(Fn.map_fun (fun g (Cons (x, Cons (y, Cons (z,Cons (w,Nil))))) -> g x y z w)) (Fn.map_fun (fun g x y z w -> g (x @:: y @:: z @:: w @:: nil))) (fun_nary (o1 @-> o2 @-> o3 @-> o4 @-> o_nil) ret) (* Generator combinators *) (** given a list, returns generator that picks at random from list *) let oneofl ?print ?collect xs = make ?print ?collect (Gen.oneofl xs) let oneofa ?print ?collect xs = make ?print ?collect (Gen.oneofa xs) (** Given a list of generators, returns generator that randomly uses one of the generators from the list *) let oneof l = let gens = List.map (fun a->a.gen) l in let first = List.hd l in let print = first.print and small = first.small and collect = first.collect and shrink = first.shrink in make ?print ?small ?collect ?shrink (Gen.oneof gens) (** Generator that always returns given value *) let always ?print x = let gen _st = x in make ?print gen (** like oneof, but with weights *) let frequency ?print ?small ?shrink ?collect l = let first = snd (List.hd l) in let small = _opt_sum small first.small in let print = _opt_sum print first.print in let shrink = _opt_sum shrink first.shrink in let collect = _opt_sum collect first.collect in let gens = List.map (fun (x,y) -> x, y.gen) l in make ?print ?small ?shrink ?collect (Gen.frequency gens) (** Given list of [(frequency,value)] pairs, returns value with probability proportional to given frequency *) let frequencyl ?print ?small l = make ?print ?small (Gen.frequencyl l) let frequencya ?print ?small l = make ?print ?small (Gen.frequencya l) let map_same_type f a = adapt_ a (fun st -> f (a.gen st)) let map_keep_input ?print ?small f a = make ?print:(match print, a.print with | Some f1, Some f2 -> Some (Print.pair f2 f1) | Some f, None -> Some (Print.comap snd f) | None, Some f -> Some (Print.comap fst f) | None, None -> None) ?small:(match small, a.small with | Some f, _ -> Some (fun (_,y) -> f y) | None, Some f -> Some (fun (x,_) -> f x) | None, None -> None) ?shrink:(match a.shrink with | None -> None | Some s -> let s' (x,_) = Iter.map (fun x->x, f x) (s x) in Some s') Gen.(map_keep_input f a.gen) module TestResult = struct type 'a counter_ex = { instance: 'a; (** The counter-example(s) *) shrink_steps: int; (** How many shrinking steps for this counterex *) msg_l: string list; (** messages. @since 0.7 *) } type 'a failed_state = 'a counter_ex list (** Result state. changed in 0.10 (move to inline records) *) type 'a state = | Success | Failed of { instances: 'a failed_state; (** Failed instance(s) *) } | Failed_other of {msg: string} | Error of { instance: 'a counter_ex; exn: exn; backtrace: string; } (** Error, backtrace, and instance that triggered it *) (* result returned by running a test *) type 'a t = { mutable state : 'a state; mutable count: int; (* number of tests *) mutable count_gen: int; (* number of generated cases *) collect_tbl: (string, int) Hashtbl.t lazy_t; stats_tbl: ('a stat * (int, int) Hashtbl.t) list; mutable warnings: string list; mutable instances: 'a list; } (* indicate failure on the given [instance] *) let fail ~msg_l ~small ~steps:shrink_steps res instance = let c_ex = {instance; shrink_steps; msg_l; } in match res.state with | Success -> res.state <- Failed {instances=[ c_ex ]} | Error _ | Failed_other _ -> () | Failed {instances=[]} -> assert false | Failed {instances=((c_ex'::_) as l)} -> match small with | Some small -> (* all counter-examples in [l] have same size according to [small], so we just compare to the first one, and we enforce the invariant *) begin match Pervasives.compare (small instance) (small c_ex'.instance) with | 0 -> res.state <- Failed {instances=c_ex :: l} (* same size: add [c_ex] to [l] *) | n when n<0 -> res.state <- Failed {instances=[c_ex]} (* drop [l] *) | _ -> () (* drop [c_ex], not small enough *) end | _ -> (* no [small] function, keep all counter-examples *) res.state <- Failed {instances=c_ex :: l} let error ~msg_l ~steps res instance exn backtrace = res.state <- Error {instance={instance; shrink_steps=steps; msg_l; }; exn; backtrace} let collect r = if Lazy.is_val r.collect_tbl then Some (Lazy.force r.collect_tbl) else None let stats r = r.stats_tbl let warnings r = r.warnings let is_success r = match r.state with | Success -> true | Failed _ | Error _ | Failed_other _ -> false end module Test = struct type 'a cell = { count : int; (* number of tests to do *) long_factor : int; (* multiplicative factor for long test count *) max_gen : int; (* max number of instances to generate (>= count) *) max_fail : int; (* max number of failures *) law : 'a -> bool; (* the law to check *) arb : 'a arbitrary; (* how to generate/print/shrink instances *) if_assumptions_fail: [`Fatal | `Warning] * float; mutable name : string; (* name of the law *) } type t = | Test : 'a cell -> t let get_name {name; _} = name let set_name c name = c.name <- name let get_law {law; _} = law let get_arbitrary {arb; _} = arb let get_count {count; _ } = count let get_long_factor {long_factor; _} = long_factor let default_count = 100 let fresh_name = let r = ref 0 in (fun () -> incr r; Printf.sprintf "anon_test_%d" !r) let default_if_assumptions_fail = `Warning, 0.05 let make_cell ?(if_assumptions_fail=default_if_assumptions_fail) ?(count=default_count) ?(long_factor=1) ?max_gen ?(max_fail=1) ?small ?(name=fresh_name()) arb law = let max_gen = match max_gen with None -> count + 200 | Some x->x in let arb = match small with None -> arb | Some f -> set_small f arb in { law; arb; max_gen; max_fail; name; count; long_factor; if_assumptions_fail; } let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law = Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law) (** {6 Running the test} *) module R = TestResult (* Result of an instance run *) type res = | Success | Failure | FalseAssumption | Error of exn * string (* Step function, called after each instance test *) type 'a step = string -> 'a cell -> 'a -> res -> unit let step_nil_ _ _ _ _ = () (* Events of a test *) type 'a event = | Generating | Collecting of 'a | Testing of 'a | Shrunk of int * 'a | Shrinking of int * int * 'a type 'a handler = string -> 'a cell -> 'a event -> unit let handler_nil_ _ _ _ = () (* state required by {!check} to execute *) type 'a state = { test: 'a cell; step: 'a step; handler : 'a handler; rand: Random.State.t; mutable res: 'a TestResult.t; mutable cur_count: int; (** number of iterations remaining to do *) mutable cur_max_gen: int; (** maximum number of generations allowed *) mutable cur_max_fail: int; (** maximum number of counter-examples allowed *) } let is_done state = state.cur_count <= 0 || state.cur_max_gen <= 0 let decr_count state = state.res.R.count <- state.res.R.count + 1; state.cur_count <- state.cur_count - 1 let new_input state = state.res.R.count_gen <- state.res.R.count_gen + 1; state.cur_max_gen <- state.cur_max_gen - 1; state.test.arb.gen state.rand (* statistics on inputs *) let collect st i = match st.test.arb.collect with | None -> () | Some f -> let key = f i in let (lazy tbl) = st.res.R.collect_tbl in let n = try Hashtbl.find tbl key with Not_found -> 0 in Hashtbl.replace tbl key (n+1) let update_stats st i = List.iter (fun ((_,f), tbl) -> let key = f i in let n = try Hashtbl.find tbl key with Not_found -> 0 in Hashtbl.replace tbl key (n+1)) st.res.R.stats_tbl type res_or_exn = | Shrink_fail | Shrink_exn of exn (* triggered by user to fail with a message *) exception User_fail of string let fail_report m = raise (User_fail m) let fail_reportf m = let buf = Buffer.create 64 in Format.kfprintf (fun out -> Format.fprintf out "@?"; fail_report (Buffer.contents buf)) (Format.formatter_of_buffer buf) m type 'a run_res = | Run_ok | Run_fail of string list let run_law law x = try if law x then Run_ok else Run_fail [] with User_fail msg -> Run_fail [msg] (* try to shrink counter-ex [i] into a smaller one. Returns shrinked value and number of steps *) let shrink st (i:'a) (r:res_or_exn) m : 'a * res_or_exn * string list * int = let is_err = match r with | Shrink_exn _ -> true | _ -> false in let rec shrink_ st i r m ~steps = st.handler st.test.name st.test (Shrunk (steps, i)); match st.test.arb.shrink with | None -> i, r, m, steps | Some f -> let count = ref 0 in let i' = Iter.find_map (fun x -> try incr count; st.handler st.test.name st.test (Shrinking (steps, !count, x)); begin match run_law st.test.law x with | Run_fail m when not is_err -> Some (x, Shrink_fail, m) | _ -> None end with | FailedPrecondition | No_example_found _ -> None | e when is_err -> Some (x, Shrink_exn e, []) (* fail test (by error) *) ) (f i) in match i' with | None -> i, r, m, steps | Some (i',r',m') -> shrink_ st i' r' m' ~steps:(steps+1) (* shrink further *) in shrink_ ~steps:0 st i r m type 'a check_result = | CR_continue | CR_yield of 'a TestResult.t (* test raised [e] on [input]; try to shrink then fail *) let handle_exn state input e bt : _ check_result = (* first, shrink TODO: shall we shrink differently (i.e. expected only an error)? *) let input, r, msg_l, steps = shrink state input (Shrink_exn e) [] in (* recover exception of shrunk input *) let e = match r with | Shrink_fail -> e | Shrink_exn e' -> e' in state.step state.test.name state.test input (Error (e, bt)); R.error state.res ~steps ~msg_l input e bt; CR_yield state.res (* test failed on [input], which means the law is wrong. Continue if we should. *) let handle_fail state input msg_l : _ check_result = (* first, shrink *) let input, _, msg_l, steps = shrink state input Shrink_fail msg_l in (* fail *) decr_count state; state.step state.test.name state.test input Failure; state.cur_max_fail <- state.cur_max_fail - 1; R.fail ~small:state.test.arb.small state.res ~steps ~msg_l input; if _is_some state.test.arb.small && state.cur_max_fail > 0 then CR_continue else CR_yield state.res (* [check_state state] applies [state.test] repeatedly ([iter] times) on output of [test.rand], and if [state.test] ever returns false, then the input that caused the failure is returned in [Failed]. If [func input] raises [FailedPrecondition] then the input is discarded, unless max_gen is 0. *) let rec check_state state = if is_done state then state.res else ( state.handler state.test.name state.test Generating; let input = new_input state in state.handler state.test.name state.test (Collecting input); state.res.R.instances <- input :: state.res.R.instances; collect state input; update_stats state input; let res = try state.handler state.test.name state.test (Testing input); begin match run_law state.test.law input with | Run_ok -> (* one test ok *) decr_count state; state.step state.test.name state.test input Success; CR_continue | Run_fail msg_l -> handle_fail state input msg_l end with | FailedPrecondition | No_example_found _ -> state.step state.test.name state.test input FalseAssumption; CR_continue | e -> let bt = Printexc.get_backtrace () in handle_exn state input e bt in match res with | CR_continue -> check_state state | CR_yield x -> x ) type 'a callback = string -> 'a cell -> 'a TestResult.t -> unit let callback_nil_ : _ callback = fun _ _ _ -> () (* check that there are sufficiently many tests which passed, to avoid the case where they all passed by failed precondition *) let check_if_assumptions target_count cell res : unit = let percentage_of_count = float_of_int res.R.count /. float_of_int target_count in let assm_flag, assm_frac = cell.if_assumptions_fail in if R.is_success res && percentage_of_count < assm_frac then ( let msg = format_of_string "%s: \ only %.1f%% tests (of %d) passed precondition for %S\n\n\ NOTE: it is likely that the precondition is too strong, or that \ the generator is buggy.\n%!" in match assm_flag with | `Warning -> let msg = Printf.sprintf msg "WARNING" (percentage_of_count *. 100.) cell.count cell.name in res.R.warnings <- msg :: res.R.warnings | `Fatal -> (* turn it into an error *) let msg = Printf.sprintf msg "ERROR" (percentage_of_count *. 100.) cell.count cell.name in res.R.state <- R.Failed_other {msg} ) (* main checking function *) let check_cell ?(long=false) ?(call=callback_nil_) ?(step=step_nil_) ?(handler=handler_nil_) ?(rand=Random.State.make [| 0 |]) cell = let factor = if long then cell.long_factor else 1 in let target_count = factor*cell.count in let state = { test=cell; rand; step; handler; cur_count=target_count; cur_max_gen=factor*cell.max_gen; cur_max_fail=factor*cell.max_fail; res = {R. state=R.Success; count=0; count_gen=0; collect_tbl=lazy (Hashtbl.create 10); instances=[]; warnings=[]; stats_tbl= List.map (fun stat -> stat, Hashtbl.create 10) cell.arb.stats; }; } in let res = check_state state in check_if_assumptions target_count cell res; call cell.name cell res; res exception Test_fail of string * string list exception Test_error of string * string * exn * string (* print instance using [arb] *) let print_instance arb i = match arb.print with | None -> "" | Some pp -> pp i let print_c_ex arb c : string = let buf = Buffer.create 64 in begin if c.R.shrink_steps > 0 then Printf.bprintf buf "%s (after %d shrink steps)" (print_instance arb c.R.instance) c.R.shrink_steps else Buffer.add_string buf (print_instance arb c.R.instance) end; List.iter (fun msg -> Buffer.add_char buf '\n'; Buffer.add_string buf msg; Buffer.add_char buf '\n') c.R.msg_l; Buffer.contents buf let pp_print_test_fail name out l = let rec pp_list out = function | [] -> () | [x] -> Format.fprintf out "%s@," x | x :: y -> Format.fprintf out "%s@,%a" x pp_list y in Format.fprintf out "@[test `%s`@ failed on ≥ %d cases:@ @[%a@]@]" name (List.length l) pp_list l let asprintf fmt = let buf = Buffer.create 128 in let out = Format.formatter_of_buffer buf in Format.kfprintf (fun _ -> Buffer.contents buf) out fmt let print_test_fail name l = asprintf "@[%a@]@?" (pp_print_test_fail name) l let print_test_error name i e stack = Format.sprintf "@[test `%s`@ raised exception `%s`@ on `%s`@,%s@]" name (Printexc.to_string e) i stack let print_collect c = let out = Buffer.create 64 in Hashtbl.iter (fun case num -> Printf.bprintf out "%s: %d cases\n" case num) c; Buffer.contents out let stat_max_lines = 20 (* maximum number of lines for a histogram *) let print_stat ((name,_), tbl) = let avg = ref 0. in let num = ref 0 in let min_idx, max_idx = Hashtbl.fold (fun i res (m1,m2) -> avg := !avg +. float_of_int (i * res); num := !num + res; min i m1, max i m2) tbl (max_int,min_int) in (* compute average *) if !num > 0 then ( avg := !avg /. float_of_int !num ); (* compute std-dev: sqroot of sum of squared distance-to-average https://en.wikipedia.org/wiki/Standard_deviation *) let stddev = Hashtbl.fold (fun i res m -> m +. (float_of_int i -. !avg) ** 2. *. float_of_int res) tbl 0. |> (fun s -> if !num>0 then s /. float_of_int !num else s) |> sqrt in (* compute median *) let median = ref 0 in let median_num = ref 0 in (* how many values have we seen yet? once >= !n/2 we set median *) (Hashtbl.fold (fun i cnt acc -> (i,cnt)::acc) tbl []) |> List.sort (fun (i,_) (j,_) -> compare i j) |> List.iter (fun (i,cnt) -> if !median_num < !num/2 then ( median_num := !median_num + cnt; (* just went above median! *) if !median_num >= !num/2 then median := i)); (* group by buckets, if there are too many entries: *) (* first compute histogram and bucket size *) let hist_size, bucket_size = let sample_width = Int64.(sub (of_int max_idx) (of_int min_idx)) in if sample_width > Int64.of_int stat_max_lines then stat_max_lines, int_of_float (ceil (Int64.to_float sample_width /. float_of_int stat_max_lines)) else max_idx-min_idx, 1 in let hist_size = if min_idx + bucket_size * hist_size <= max_idx then 1+hist_size else hist_size in (* accumulate bucket counts *) let max_val = ref 0 in (* max value after grouping by buckets *) let bucket_count = Array.init hist_size (fun _ -> 0) in Hashtbl.iter (fun j count -> let bucket = Int64.(to_int (div (sub (of_int j) (of_int min_idx)) (of_int bucket_size))) in let new_count = bucket_count.(bucket) + count in bucket_count.(bucket) <- new_count; max_val := max !max_val new_count) tbl; (* print entries of the table, sorted by increasing index *) let out = Buffer.create 128 in Printf.bprintf out "stats %s:\n" name; Printf.bprintf out " num: %d, avg: %.2f, stddev: %.2f, median %d, min %d, max %d\n" !num !avg stddev !median min_idx max_idx; let indwidth = max (String.length (Printf.sprintf "%d" min_idx)) (max (String.length (Printf.sprintf "%d" max_idx)) (String.length (Printf.sprintf "%d" (min_idx + bucket_size * hist_size)))) in let labwidth = if bucket_size=1 then indwidth else 2+2*indwidth in for i = 0 to hist_size - 1 do let i' = min_idx + i * bucket_size in let blabel = if bucket_size=1 then Printf.sprintf "%*d" indwidth i' else let bucket_bound = i'+bucket_size-1 in Printf.sprintf "%*d..%*d" indwidth i' indwidth (if bucket_bound < i' then max_int else bucket_bound) in let bcount = bucket_count.(i) in (* NOTE: keep in sync *) let bar_len = bcount * 55 / !max_val in Printf.bprintf out " %*s: %-56s %10d\n" labwidth blabel (String.make bar_len '#') bcount done; Buffer.contents out let () = Printexc.register_printer (function | Test_fail (name,l) -> Some (print_test_fail name l) | Test_error (name,i,e,st) -> Some (print_test_error name i e st) | _ -> None) let print_fail arb name l = print_test_fail name (List.map (print_c_ex arb) l) let print_fail_other name ~msg = print_test_fail name [msg] let print_error ?(st="") arb name (i,e) = print_test_error name (print_c_ex arb i) e st let check_result cell res = match res.R.state with | R.Success -> () | R.Error {instance; exn; backtrace} -> raise (Test_error (cell.name, print_c_ex cell.arb instance, exn, backtrace)) | R.Failed {instances=l} -> let l = List.map (print_c_ex cell.arb) l in raise (Test_fail (cell.name, l)) | R.Failed_other {msg} -> raise (Test_fail (cell.name, [msg])) let check_cell_exn ?long ?call ?step ?rand cell = let res = check_cell ?long ?call ?step ?rand cell in check_result cell res let check_exn ?long ?rand (Test cell) = check_cell_exn ?long ?rand cell end let find_example ?(name="") ?count ~f g : _ Gen.t = (* the random generator of examples satisfying [f]. To do that we test the property [fun x -> not (f x)]; any counter-example *) let gen st = let cell = let arb = make g in Test.make_cell ~max_fail:1 ?count arb (fun x -> not (f x)) in let res = Test.check_cell ~rand:st cell in begin match res.TestResult.state with | TestResult.Success -> raise (No_example_found name) | TestResult.Error _ -> raise (No_example_found name) | TestResult.Failed {instances=[]} -> assert false | TestResult.Failed {instances=failed::_} -> (* found counter-example! *) failed.TestResult.instance | TestResult.Failed_other {msg=_} -> raise (No_example_found name) end in gen let find_example_gen ?rand ?name ?count ~f g = let g = find_example ?name ?count ~f g in Gen.generate1 ?rand g qcheck-0.11/src/core/QCheck.mli000066400000000000000000001237561354513211100162630ustar00rootroot00000000000000(* QCheck: Random testing for OCaml copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard all rights reserved. *) (** {1 Quickcheck inspired property-based testing} *) (** The library takes inspiration from Haskell's QuickCheck library. The rough idea is that the programmer describes invariants that values of a certain type need to satisfy ("properties"), as functions from this type to bool. She also needs to describe how to generate random values of the type, so that the property is tried and checked on a number of random instances. This explains the organization of this module: - {! 'a arbitrary} is used to describe how to generate random values, shrink them (make counter-examples as small as possible), print them, etc. Auxiliary modules such as {!Gen}, {!Print}, and {!Shrink} can be used along with {!make} to build one's own arbitrary instances. - {!Test} is used to describe a single test, that is, a property of type ['a -> bool] combined with an ['a arbitrary] that is used to generate the test cases for this property. Optional parameters allow to specify the random generator state, number of instances to generate and test, etc. Examples: - List.rev is involutive: {[ let test = QCheck.(Test.make ~count:1000 (list int) (fun l -> List.rev (List.rev l) = l));; QCheck.Test.check_exn test;; ]} - Not all lists are sorted (false property that will fail. The 15 smallest counter-example lists will be printed): {[ let test = QCheck.( Test.make ~count:10_000 ~max_fail:3 (list small_nat) (fun l -> l = List.sort compare l));; QCheck.Test.check_exn test;; ]} - generate 20 random trees using {! Gen.fix} : {[ type tree = Leaf of int | Node of tree * tree let leaf x = Leaf x let node x y = Node (x,y) let g = QCheck.Gen.(sized @@ fix (fun self n -> match n with | 0 -> map leaf nat | n -> frequency [1, map leaf nat; 2, map2 node (self (n/2)) (self (n/2))] )) Gen.generate ~n:20 g;; ]} More complex and powerful combinators can be found in Gabriel Scherer's {!Generator} module. Its documentation can be found {{:http://gasche.github.io/random-generator/doc/Generator.html } here}. *) val (==>) : bool -> bool -> bool (** [b1 ==> b2] is the logical implication [b1 => b2] ie [not b1 || b2] (except that it is strict and will interact better with {!Test.check_exn} and the likes, because they will know the precondition was not satisfied.). {b WARNING}: this function should only be used in a property (see {!Test.make}), because it raises a special exception in case of failure of the first argument, to distinguish between failed test and failed precondition. Because of OCaml's evaluation order, both [b1] and [b2] are always evaluated; if [b2] should only be evaluated when [b1] holds, see {!assume}. *) val assume : bool -> unit (** [assume cond] checks the precondition [cond], and does nothing if [cond=true]. If [cond=false], it interrupts the current test. {b WARNING} This function, like {!(==>)}, should only be used in a test, not outside. Example: {[ Test.make (list int) (fun l -> assume (l <> []); List.hd l :: List.tl l = l) ]} @since 0.5.1 *) val assume_fail : unit -> 'a (** [assume_fail ()] is like [assume false], but can take any type since we know it always fails (like [assert false]). This is useful to ignore some branches in [if] or [match]. Example: {[ Test.make (list int) (function | [] -> assume_fail () | _::_ as l -> List.hd l :: List.tl l = l) ]} @since 0.5.1 *) (** {2 Generate Random Values} *) module Gen : sig type 'a t = Random.State.t -> 'a (** A random generator for values of type 'a. *) type 'a sized = int -> Random.State.t -> 'a (** Random generator with a size bound. *) val return : 'a -> 'a t (** Create a constant generator. *) val pure : 'a -> 'a t (** Synonym for {!return} @since 0.8 *) val (>>=) : 'a t -> ('a -> 'b t) -> 'b t (** Monadic bind for writing dependent generators. First generates an ['a] and then passes it to the given function, to generate a ['b]. *) val (<*>) : ('a -> 'b) t -> 'a t -> 'b t (** Infix operator for composing a function generator and an argument generator into a result generator. *) val map : ('a -> 'b) -> 'a t -> 'b t (** [map f g] transforms a generator [g] by applying [f] to each generated element. *) val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [map2 f g1 g2] transforms two generators [g1] and [g2] by applying [f] to each pair of generated elements. *) val map3 : ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t (** [map3 f g1 g2 g3] transforms three generators [g1], [g2], and [g3] by applying [f] to each triple of generated elements. *) val map_keep_input : ('a -> 'b) -> 'a t -> ('a * 'b) t (** [map_keep_input f g] transforms a generator [g] by applying [f] to each generated element. Returns both the generated element from [g] and the output from [f]. *) val (>|=) : 'a t -> ('a -> 'b) -> 'b t (** An infix synonym for {!map}. *) val oneof : 'a t list -> 'a t (** Constructs a generator that selects among a given list of generators. *) val oneofl : 'a list -> 'a t (** Constructs a generator that selects among a given list of values. *) val oneofa : 'a array -> 'a t (** Constructs a generator that selects among a given array of values. *) val frequency : (int * 'a t) list -> 'a t (** Constructs a generator that selects among a given list of generators. Each of the given generators are chosen based on a positive integer weight. *) val frequencyl : (int * 'a) list -> 'a t (** Constructs a generator that selects among a given list of values. Each of the given values are chosen based on a positive integer weight. *) val frequencya : (int * 'a) array -> 'a t (** Constructs a generator that selects among a given array of values. Each of the array entries are chosen based on a positive integer weight. *) val shuffle_a : 'a array -> unit t (** Shuffles the array in place. *) val shuffle_l : 'a list -> 'a list t (** Creates a generator of shuffled lists. *) val shuffle_w_l : (int * 'a) list -> 'a list t (** Creates a generator of weighted shuffled lists. A given list is shuffled on each generation according to the weights of its elements. An element with a larger weight is more likely to be at the front of the list than an element with a smaller weight. If we want to pick random elements from the (head of) list but need to prioritize some elements over others, this generator can be useful. Example: given a weighted list [[1, "one"; 5, "five"; 10, "ten"]], the generator is more likely to generate [["ten"; "five"; "one"]] or [["five"; "ten"; "one"]] than [["one"; "ten"; "five"]] because "ten" and "five" have larger weights than "one". @since 0.11 *) val unit : unit t (** The unit generator. *) val bool : bool t (** The boolean generator. *) val float : float t (** Generates floating point numbers. *) val pfloat : float t (** Generates positive floating point numbers (0. included). *) val nfloat : float t (** Generates negative floating point numbers. (-0. included) *) val float_bound_inclusive : float -> float t (** [float_bound_inclusive bound] returns a random floating-point number between 0 and [bound] (inclusive). If [bound] is negative, the result is negative or zero. If [bound] is 0, the result is 0. @since 0.11 *) val float_bound_exclusive : float -> float t (** [float_bound_exclusive bound] returns a random floating-point number between 0 and [bound] (exclusive). If [bound] is negative, the result is negative or zero. @raise Invalid_argument if [bound] is zero. @since 0.11 *) val float_range : float -> float -> float t (** [float_range low high] generates floating-point numbers within [low] and [high] (inclusive) @raise Invalid_argument if [high < low] or if the range is larger than [max_float]. @since 0.11 *) val (--.) : float -> float -> float t (** Synonym for [float_range] @since 0.11 *) val nat : int t (** Generates small natural numbers. *) val big_nat : int t (** Generates natural numbers, possibly large. @since 0.10 *) val neg_int : int t (** Generates non-strictly negative integers (0 included). *) val pint : int t (** Generates non-strictly positive integers uniformly (0 included). *) val int : int t (** Generates integers uniformly. *) val small_nat : int t (** Small integers (< 100) @since 0.5.1 *) val small_int : int t (** Small UNSIGNED integers, for retrocompatibility. @deprecated use {!small_nat}. *) val small_signed_int : int t (** Small SIGNED integers, based on {!small_nat}. @since 0.5.2 *) val int_bound : int -> int t (** Uniform integer generator producing integers within [0... bound]. For [bound < 2^{30} - 1] uses [Random.State.int] for integer generation. @raise Invalid_argument if the argument is negative. *) val int_range : int -> int -> int t (** Uniform integer generator producing integers within [low,high]. @raise Invalid_argument if [low > high] or if the range is larger than [max_int]. *) val graft_corners : 'a t -> 'a list -> unit -> 'a t (** [graft_corners gen l ()] makes a new generator that enumerates the corner cases in [l] and then behaves like [g]. @since 0.6 *) val int_pos_corners : int list (** Non-negative corner cases for int. @since 0.6 *) val int_corners : int list (** All corner cases for int. @since 0.6 *) val (--) : int -> int -> int t (** Synonym to {!int_range}. *) val ui32 : int32 t (** Generates (unsigned) [int32] values. *) val ui64 : int64 t (** Generates (unsigned) [int64] values. *) val list : 'a t -> 'a list t (** Builds a list generator from an element generator. List size is generated by {!nat}. *) val list_size : int t -> 'a t -> 'a list t (** Builds a list generator from a (non-negative) size generator and an element generator. *) val list_repeat : int -> 'a t -> 'a list t (** [list_repeat i g] builds a list generator from exactly [i] elements generated by [g]. *) val array : 'a t -> 'a array t (** Builds an array generator from an element generator. Array size is generated by {!nat}. *) val array_size : int t -> 'a t -> 'a array t (** Builds an array generator from a (non-negative) size generator and an element generator. *) val array_repeat : int -> 'a t -> 'a array t (** [array_repeat i g] builds an array generator from exactly [i] elements generated by [g]. *) val opt : 'a t -> 'a option t (** An option generator. *) val pair : 'a t -> 'b t -> ('a * 'b) t (** Generates pairs. *) val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t (** Generates triples. *) val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t (** Generates quadruples. @since 0.5.1 *) val char : char t (** Generates characters upto character code 255. *) val printable : char t (** Generates printable characters. *) val numeral : char t (** Generates numeral characters. *) val string_size : ?gen:char t -> int t -> string t (** Builds a string generator from a (non-negative) size generator. Accepts an optional character generator (the default is {!char}). *) val string : ?gen:char t -> string t (** Builds a string generator. String size is generated by {!nat}. Accepts an optional character generator (the default is {!char}). See also {!string_of} and {!string_readable} for versions without optional parameters. *) val string_of : char t -> string t (** Builds a string generator using the given character generator. @since 0.11 *) val string_readable : string t (** Builds a string generator using the {!char} character generator. @since 0.11 *) val small_string : ?gen:char t -> string t (** Builds a string generator, length is {!small_nat} Accepts an optional character generator (the default is {!char}). *) val small_list : 'a t -> 'a list t (** Generates lists of small size (see {!small_nat}). @since 0.5.3 *) val small_array : 'a t -> 'a array t (** Generates arrays of small size (see {!small_nat}). @since 0.10 *) val join : 'a t t -> 'a t (** Collapses a generator of generators to simply a generator. @since 0.5 *) val sized : 'a sized -> 'a t (** Creates a generator from a size-bounded generator by first generating a size using {!nat} and passing the result to the size-bounded generator. *) val sized_size : int t -> 'a sized -> 'a t (** Creates a generator from a size-bounded generator by first generating a size using the integer generator and passing the result to the size-bounded generator. @since 0.5 *) val fix : (('a -> 'b t) -> ('a -> 'b t)) -> 'a -> 'b t (** Parametrized fixpoint combinator for generating recursive values. The fixpoint is parametrized over an arbitrary state ('a), and the fixpoint computation may change the value of this state in the recursive calls. In particular, this can be used for size-bounded generators ('a is int). The passed size-parameter should decrease to ensure termination. *) (** Example: {[ type tree = Leaf of int | Node of tree * tree let leaf x = Leaf x let node x y = Node (x,y) let g = QCheck.Gen.(sized @@ fix (fun self n -> match n with | 0 -> map leaf nat | n -> frequency [1, map leaf nat; 2, map2 node (self (n/2)) (self (n/2))] )) ]} *) val generate : ?rand:Random.State.t -> n:int -> 'a t -> 'a list (** [generate ~n g] generates [n] instances of [g]. *) val generate1 : ?rand:Random.State.t -> 'a t -> 'a (** [generate1 g] generates one instance of [g]. *) end (** {2 Pretty printing} *) (** {2 Show Values} *) module Print : sig type 'a t = 'a -> string (** Printer for values of type ['a]. *) val unit : unit t (** @since 0.6 *) val int : int t (** Integer printer. *) val bool : bool t (** Boolean printer. *) val float : float t (** Floating point number printer. *) val char : char t (** Character printer. *) val string : string t (** String printer. *) val option : 'a t -> 'a option t (** Option printer. *) val pair : 'a t -> 'b t -> ('a*'b) t (** Pair printer. Expects printers for each component. *) val triple : 'a t -> 'b t -> 'c t -> ('a*'b*'c) t (** Triple (3-tuple) printer. Expects printers for each component. *) val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a*'b*'c*'d) t (** Quadruple (4-tuple) printer. Expects printers for each component. *) val list : 'a t -> 'a list t (** List printer. Expects a printer for the list element type. *) val array : 'a t -> 'a array t (** Array printer. Expects a printer for the array entry type. *) val comap : ('a -> 'b) -> 'b t -> 'a t (** [comap f p] maps [p], a printer of type ['b], to a printer of type ['a] by first converting a printed value using [f : 'a -> 'b]. *) end (** {2 Iterators} Compatible with the library "sequence". An iterator [i] is simply a function that accepts another function [f] (of type ['a -> unit]) and calls [f] on a sequence of elements [f x1; f x2; ...; f xn]. *) module Iter : sig type 'a t = ('a -> unit) -> unit val empty : 'a t val return : 'a -> 'a t val (<*>) : ('a -> 'b) t -> 'a t -> 'b t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t val (>|=) : 'a t -> ('a -> 'b) -> 'b t val append : 'a t -> 'a t -> 'a t val (<+>) : 'a t -> 'a t -> 'a t (** Synonym to {!append}. *) val of_list : 'a list -> 'a t val of_array : 'a array -> 'a t val pair : 'a t -> 'b t -> ('a * 'b) t val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t val find : ('a -> bool) -> 'a t -> 'a option val filter : ('a -> bool) -> 'a t -> 'a t val append_l : 'a t list -> 'a t (** @since 0.8 *) val flatten : 'a t t -> 'a t (** @since 0.8 *) end (** {2 Shrink Values} Shrinking is used to reduce the size of a counter-example. It tries to make the counter-example smaller by decreasing it, or removing elements, until the property to test holds again; then it returns the smallest value that still made the test fail. *) module Shrink : sig type 'a t = 'a -> 'a Iter.t (** Given a counter-example, return an iterator on smaller versions of the counter-example. *) val nil : 'a t (** No shrink *) val unit : unit t (** @since 0.6 *) val char : char t (** @since 0.6 *) val int : int t val option : 'a t -> 'a option t val string : string t val filter : ('a -> bool) -> 'a t -> 'a t (** [filter f shrink] shrinks values the same as [shrink], but only keep smaller values that satisfy [f]. This way it's easy to preserve invariants that are enforced by generators, when shrinking values @since 0.8 *) val int_aggressive : int t (** Shrink integers by trying all smaller integers (can take a lot of time!) @since 0.7 *) val list : ?shrink:'a t -> 'a list t (** Try to shrink lists by removing one or more elements. @param shrink if provided, will be used to also try to reduce the elements of the list themselves (e.g. in an [int list] one can try to decrease the integers). *) val list_spine : 'a list t (** Try to shrink lists by removing one or more elements. @since 0.10 *) val list_elems : 'a t -> 'a list t (** Shrinks the elements of a list, without changing the list size. @since 0.10 *) val array : ?shrink:'a t -> 'a array t (** Shrink an array. @param shrink see {!list} *) val pair : 'a t -> 'b t -> ('a * 'b) t (** [pair a b] uses [a] to shrink the first element of tuples, then tries to shrink the second element using [b]. It is often better, when generating tuples, to put the "simplest" element first (atomic type rather than list, etc.) because it will be shrunk earlier. In particular, putting functions last might help. *) val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t (** Similar to {!pair} *) val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t (** Similar to {!pair} *) end (** {2 Observe Values} *) (** Observables are usable as arguments for random functions. The random function will observe its arguments in a way that is determined from the observable instance. Inspired from https://blogs.janestreet.com/quickcheck-for-core/ and Koen Claessen's "Shrinking and Showing functions". @since 0.6 *) module Observable : sig (** An observable for ['a], packing a printer and other things. *) type -'a t val equal : 'a t -> 'a -> 'a -> bool val hash : 'a t -> 'a -> int val print : 'a t -> 'a Print.t val unit : unit t val bool : bool t val int : int t val float : float t val string : string t val char : char t val make : ?eq:('a -> 'a -> bool) -> ?hash:('a -> int) -> 'a Print.t -> 'a t val map : ('a -> 'b) -> 'b t -> 'a t val option : 'a t -> 'a option t val list : 'a t -> 'a list t val array : 'a t -> 'a array t val pair : 'a t -> 'b t -> ('a * 'b) t val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t end (** {2 Arbitrary} A value of type ['a arbitrary] glues together a random generator, and optional functions for shrinking, printing, computing the size, etc. It is the "normal" way of describing how to generate values of a given type, to be then used in tests (see {!Test}). *) type 'a stat = string * ('a -> int) (** A statistic on a distribution of values of type ['a]. The function {b MUST} return a positive integer. *) type 'a arbitrary = private { gen: 'a Gen.t; print: ('a -> string) option; (** print values *) small: ('a -> int) option; (** size of example *) shrink: ('a Shrink.t) option; (** shrink to smaller examples *) collect: ('a -> string) option; (** map value to tag, and group by tag *) stats: 'a stat list; (** statistics to collect and print *) } (** A value of type ['a arbitrary] is an object with a method for generating random values of type ['a], and additional methods to compute the size of values, print them, and possibly shrink them into smaller counter-examples. {b NOTE} the collect field is unstable and might be removed, or moved into {!Test}. Made private @since 0.8 *) val make : ?print:'a Print.t -> ?small:('a -> int) -> ?shrink:'a Shrink.t -> ?collect:('a -> string) -> ?stats:'a stat list -> 'a Gen.t -> 'a arbitrary (** Builder for arbitrary. Default is to only have a generator, but other arguments can be added. @param print printer for values (counter-examples) @param collect for statistics @param shrink to shrink counter-examples *) val set_print : 'a Print.t -> 'a arbitrary -> 'a arbitrary val set_small : ('a -> int) -> 'a arbitrary -> 'a arbitrary val set_shrink : 'a Shrink.t -> 'a arbitrary -> 'a arbitrary val set_collect : ('a -> string) -> 'a arbitrary -> 'a arbitrary val set_stats : 'a stat list -> 'a arbitrary -> 'a arbitrary (** @since 0.6 *) val add_shrink_invariant : ('a -> bool) -> 'a arbitrary -> 'a arbitrary (** Update shrinker by only keeping smaller values satisfying the given invariant. @since 0.8 *) val set_gen : 'a Gen.t -> 'a arbitrary -> 'a arbitrary (** Change the generator @since 0.7 *) val add_stat : 'a stat -> 'a arbitrary -> 'a arbitrary (** Add a statistic to the arbitrary instance. @since 0.6 *) val gen : 'a arbitrary -> 'a Gen.t (** Access the underlying random generator of this arbitrary object. @since 0.6 *) (** {2 Tests} A test is a universal property of type [foo -> bool] for some type [foo], with an object of type [foo arbitrary] used to generate, print, etc. values of type [foo]. See {!Test.make} to build a test, and {!Test.check_exn} to run one test simply. For more serious testing, it is better to create a testsuite and use {!QCheck_runner}. *) (** Result of running a test *) module TestResult : sig type 'a counter_ex = { instance: 'a; (** The counter-example(s) *) shrink_steps: int; (** How many shrinking steps for this counterex *) msg_l: string list; (** messages. @since 0.7 *) } type 'a failed_state = 'a counter_ex list (** Result state. changed in 0.10 (move to inline records, add Fail_other) *) type 'a state = | Success | Failed of { instances: 'a failed_state; (** Failed instance(s) *) } | Failed_other of {msg: string} | Error of { instance: 'a counter_ex; exn: exn; backtrace: string; } (** Error, backtrace, and instance that triggered it *) (* result returned by running a test *) type 'a t = private { mutable state : 'a state; mutable count: int; (* Number of tests *) mutable count_gen: int; (* Number of generated cases *) collect_tbl: (string, int) Hashtbl.t lazy_t; stats_tbl: ('a stat * (int, int) Hashtbl.t) list; (** @since 0.6 *) mutable warnings: string list; mutable instances: 'a list; (** List of instances used for this test, in no particular order. @since 0.9 *) } val collect : _ t -> (string,int) Hashtbl.t option (** Obtain statistics @since 0.6 *) val stats : 'a t -> ('a stat * (int,int) Hashtbl.t) list (** Obtain statistics @since 0.6 *) val warnings : _ t -> string list (** Obtain list of warnings @since 0.10 *) val is_success : _ t -> bool (** Returns true iff the state if [Success] @since 0.9 *) end module Test : sig type 'a cell (** A single property test *) val fail_report : string -> 'a (** Fail the test with some additional message that will be reported. @since 0.7 *) val fail_reportf : ('a, Format.formatter, unit, 'b) format4 -> 'a (** Format version of {!fail_report} @since 0.7 *) val make_cell : ?if_assumptions_fail:([`Fatal | `Warning] * float) -> ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) -> 'a cell (** [make_cell arb prop] builds a test that checks property [prop] on instances of the generator [arb]. @param name the name of the test. @param count number of test cases to run, counting only the test cases which satisfy preconditions. @param long_factor the factor by which to multiply count, max_gen and max_fail when running a long test (default: 1). @param max_gen maximum number of times the generation function is called in total to replace inputs that do not satisfy preconditions (should be >= count). @param max_fail maximum number of failures before we stop generating inputs. This is useful if shrinking takes too much time. @param small kept for compatibility reasons; if provided, replaces the field [arbitrary.small]. If there is no shrinking function but there is a [small] function, only the smallest failures will be printed. @param if_assumptions_fail the minimum fraction of tests that must satisfy the precondition for a success to be considered valid. The fraction should be between 0. and 1. A warning will be emitted otherwise if the flag is [`Warning], the test will be a failure if the flag is [`Fatal]. (since 0.10) *) val get_arbitrary : 'a cell -> 'a arbitrary val get_law : 'a cell -> ('a -> bool) val get_name : _ cell -> string val set_name : _ cell -> string -> unit val get_count : _ cell -> int (** Get the count of a cell. @since 0.5.3 *) val get_long_factor : _ cell -> int (** Get the long factor of a cell. @since 0.5.3 *) type t = Test : 'a cell -> t (** Same as ['a cell], but masking the type parameter. This allows to put tests on different types in the same list of tests. *) val make : ?if_assumptions_fail:([`Fatal | `Warning] * float) -> ?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) -> t (** [make arb prop] builds a test that checks property [prop] on instances of the generator [arb]. See {!make_cell} for a description of the parameters. *) (** {6 Running the test} *) exception Test_fail of string * string list (** Exception raised when a test failed, with the list of counter-examples. [Test_fail (name, l)] means test [name] failed on elements of [l]. *) exception Test_error of string * string * exn * string (** Exception raised when a test raised an exception [e], with the sample that triggered the exception. [Test_error (name, i, e, st)] means [name] failed on [i] with exception [e], and [st] is the stacktrace (if enabled) or an empty string. *) val print_instance : 'a arbitrary -> 'a -> string val print_c_ex : 'a arbitrary -> 'a TestResult.counter_ex -> string val print_fail : 'a arbitrary -> string -> 'a TestResult.counter_ex list -> string val print_fail_other : string -> msg:string -> string val print_error : ?st:string -> 'a arbitrary -> string -> 'a TestResult.counter_ex * exn -> string val print_test_fail : string -> string list -> string val print_test_error : string -> string -> exn -> string -> string val print_collect : (string,int) Hashtbl.t -> string (** Print "collect" results. @since 0.6 *) val print_stat : ('a stat * (int,int) Hashtbl.t) -> string (** Print statistics. @since 0.6 *) val check_result : 'a cell -> 'a TestResult.t -> unit (** [check_result cell res] checks that [res] is [Ok _], and returns unit. Otherwise, it raises some exception. @raise Test_error if [res = Error _] @raise Test_error if [res = Failed _] *) type res = | Success | Failure | FalseAssumption | Error of exn * string type 'a event = | Generating | Collecting of 'a | Testing of 'a | Shrunk of int * 'a | Shrinking of int * int * 'a type 'a handler = string -> 'a cell -> 'a event -> unit (** Handler executed after each event during testing of an instance. *) type 'a step = string -> 'a cell -> 'a -> res -> unit (** Callback executed after each instance of a test has been run. The callback is given the instance tested, and the current results of the test. *) type 'a callback = string -> 'a cell -> 'a TestResult.t -> unit (** Callback executed after each test has been run. [f name cell res] means test [cell], named [name], gave [res]. *) val check_cell : ?long:bool -> ?call:'a callback -> ?step:'a step -> ?handler:'a handler -> ?rand:Random.State.t -> 'a cell -> 'a TestResult.t (** [check_cell ~long ~rand test] generates up to [count] random values of type ['a] using [arbitrary] and the random state [st]. The predicate [law] is called on them and if it returns [false] or raises an exception then we have a counter-example for the [law]. @param long if [true] then multiply the number of instances to generate by the cell's long_factor. @param call function called on each test case, with the result. @param step function called on each instance of the test case, with the result. @return the result of the test. *) val check_cell_exn : ?long:bool -> ?call:'a callback -> ?step:'a step -> ?rand:Random.State.t -> 'a cell -> unit (** Same as {!check_cell} but calls {!check_result} on the result. @raise Test_error if [res = Error _] @raise Test_error if [res = Failed _] *) val check_exn : ?long:bool -> ?rand:Random.State.t -> t -> unit (** Checks the property against some test cases, and calls {!check_result}, which might raise an exception in case of failure. @raise Test_error if [res = Error _] @raise Test_error if [res = Failed _] *) end (** {2 Sub-tests} *) (** The infrastructure used to find counter-examples to properties can also be used to find data satisfying a predicate, {i within a property being tested}. See https://github.com/c-cube/qcheck/issues/31 *) exception No_example_found of string val find_example : ?name:string -> ?count:int -> f:('a -> bool) -> 'a Gen.t -> 'a Gen.t (** [find_example ~f gen] uses [gen] to generate some values of type ['a], and checks them against [f]. If such a value is found, it is returned. Otherwise an exception is raised. {b NOTE} this should only be used from within a property in {!Test.make}. @param count number of attempts. @param name description of the example to find (used in the exception). @param f the property that the example must satisfy. @raise No_example_found if no example is found within [count] tries. @since 0.6 *) val find_example_gen : ?rand:Random.State.t -> ?name:string -> ?count:int -> f:('a -> bool) -> 'a Gen.t -> 'a (** Toplevel version of {!find_example}. [find_example_gen ~f arb ~n] is roughly the same as [Gen.generate1 (find_example ~f arb |> gen)]. @param rand the random state to use to generate inputs. @raise No_example_found if no example was found within [count] tries. @since 0.6 *) (** {2 Combinators for {!arbitrary}} *) val choose : 'a arbitrary list -> 'a arbitrary (** Choose among the given list of generators. The list must not be empty; if it is Invalid_argument is raised. *) val unit : unit arbitrary (** Always generates [()], obviously. *) val bool : bool arbitrary (** Uniform boolean generator. *) val float : float arbitrary (** Generates regular floats (no nan and no infinities). *) (* FIXME: does not generate nan nor infinity I think. *) val pos_float : float arbitrary (** Positive float generator (no nan and no infinities). *) val neg_float : float arbitrary (** Negative float generator (no nan and no infinities). *) val float_bound_inclusive : float -> float arbitrary (** [float_bound_inclusive n] is uniform between [0] and [n] included. If [bound] is negative, the result is negative or zero. If [bound] is 0, the result is 0. @since 0.11 *) val float_bound_exclusive : float -> float arbitrary (** [float_bound_exclusive n] is uniform between [0] included and [n] excluded. If [bound] is negative, the result is negative or zero. @raise Invalid_argument if [bound] is zero. @since 0.11 *) val float_range : float -> float -> float arbitrary (** [float_range low high] is uniform between [low] included and [high] included. @raise Invalid_argument if [low > high] or if the range is larger than [max_float]. @since 0.11 *) val int : int arbitrary (** Int generator. Uniformly distributed. *) val int_bound : int -> int arbitrary (** [int_bound n] is uniform between [0] and [n] included. *) val int_range : int -> int -> int arbitrary (** [int_range a b] is uniform between [a] and [b] included. [b] must be larger than [a]. *) val small_nat : int arbitrary (** Small unsigned integers. @since 0.5.1 *) val small_int : int arbitrary (** Small unsigned integers. See {!Gen.small_int}. @deprecated use {!small_signed_int}. *) val small_signed_int : int arbitrary (** Small signed integers. @since 0.5.2 *) val (--) : int -> int -> int arbitrary (** Synonym to {!int_range}. *) val int32 : int32 arbitrary (** Int32 generator. Uniformly distributed. *) val int64 : int64 arbitrary (** Int64 generator. Uniformly distributed. *) val pos_int : int arbitrary (** Positive int generator (0 included). Uniformly distributed. See {!Gen.pint} *) val small_int_corners : unit -> int arbitrary (** As [small_int], but each newly created generator starts with a list of corner cases before falling back on random generation. *) val neg_int : int arbitrary (** Negative int generator (0 included, see {!Gen.neg_int}). The distribution is similar to that of [small_int], not of [pos_int]. *) val char : char arbitrary (** Uniformly distributed on all the chars (not just ascii or valid latin-1). *) val printable_char : char arbitrary (** Uniformly distributed over a subset of chars. *) (* FIXME: describe which subset. *) val numeral_char : char arbitrary (** Uniformly distributed over ['0'..'9']. *) val string_gen_of_size : int Gen.t -> char Gen.t -> string arbitrary val string_gen : char Gen.t -> string arbitrary (** Generates strings with a distribution of length of [small_nat]. *) val string : string arbitrary (** Generates strings with a distribution of length of [small_nat] and distribution of characters of [char]. *) val small_string : string arbitrary (** Same as {!string} but with a small length (ie {!Gen.small_nat} ). *) val small_list : 'a arbitrary -> 'a list arbitrary (** Generates lists of small size (see {!Gen.small_nat}). @since 0.5.3 *) val string_of_size : int Gen.t -> string arbitrary (** Generates strings with distribution of characters if [char]. *) val printable_string : string arbitrary (** Generates strings with a distribution of length of [small_nat] and distribution of characters of [printable_char]. *) val printable_string_of_size : int Gen.t -> string arbitrary (** Generates strings with distribution of characters of [printable_char]. *) val small_printable_string : string arbitrary val numeral_string : string arbitrary (** Generates strings with a distribution of length of [small_nat] and distribution of characters of [numeral_char]. *) val numeral_string_of_size : int Gen.t -> string arbitrary (** Generates strings with a distribution of characters of [numeral_char]. *) val list : 'a arbitrary -> 'a list arbitrary (** Generates lists with length generated by [small_nat]. *) val list_of_size : int Gen.t -> 'a arbitrary -> 'a list arbitrary (** Generates lists with length from the given distribution. *) val array : 'a arbitrary -> 'a array arbitrary (** Generates arrays with length generated by [small_nat]. *) val array_of_size : int Gen.t -> 'a arbitrary -> 'a array arbitrary (** Generates arrays with length from the given distribution. *) val pair : 'a arbitrary -> 'b arbitrary -> ('a * 'b) arbitrary (** Combines two generators into a generator of pairs. Order of elements can matter (w.r.t shrinking, see {!Shrink.pair}) *) val triple : 'a arbitrary -> 'b arbitrary -> 'c arbitrary -> ('a * 'b * 'c) arbitrary (** Combines three generators into a generator of 3-tuples. Order matters for shrinking, see {!Shrink.pair} and the likes *) val quad : 'a arbitrary -> 'b arbitrary -> 'c arbitrary -> 'd arbitrary -> ('a * 'b * 'c * 'd) arbitrary (** Combines four generators into a generator of 4-tuples. Order matters for shrinking, see {!Shrink.pair} and the likes *) val option : 'a arbitrary -> 'a option arbitrary (** Choose between returning Some random value, or None. *) val fun1_unsafe : 'a arbitrary -> 'b arbitrary -> ('a -> 'b) arbitrary (** Generator of functions of arity 1. The functions are always pure and total functions: - when given the same argument (as decided by Pervasives.(=)), it returns the same value - it never does side effects, like printing or never raise exceptions etc. The functions generated are really printable. renamed from {!fun1}. @since 0.6 @deprecated use {!fun_} instead. @since 0.6 *) val fun2_unsafe : 'a arbitrary -> 'b arbitrary -> 'c arbitrary -> ('a -> 'b -> 'c) arbitrary (** Generator of functions of arity 2. The remark about [fun1] also apply here. renamed from {!fun2}. @since 0.6 @deprecated use {!fun_} instead. @since 0.6 *) type _ fun_repr (** Internal data for functions. A ['f fun_] is a function of type ['f], fundamentally. *) (** A function packed with the data required to print/shrink it. See {!Fn} to see how to apply, print, etc. such a function. One can also directly pattern match on it to obtain the executable function. For example: {[ QCheck.Test.make QCheck.(pair (fun1 Observable.int bool) (small_list int)) (fun (Fun (_,f), l) -> l=(List.rev_map f l |> List.rev l)) ]} *) type _ fun_ = | Fun : 'f fun_repr * 'f -> 'f fun_ (** Utils on functions @since 0.6 *) module Fn : sig type 'a t = 'a fun_ val print : _ t Print.t val shrink : _ t Shrink.t val apply : 'f t -> 'f end val fun1 : 'a Observable.t -> 'b arbitrary -> ('a -> 'b) fun_ arbitrary (** [fun1 o ret] makes random functions that take an argument observable via [o] and map to random values generated from [ret]. To write functions with multiple arguments, it's better to use {!Tuple} or {!Observable.pair} rather than applying {!fun_} several times (shrinking will be faster). @since 0.6 *) module Tuple : sig (** Heterogeneous tuple, used to pass any number of arguments to a function. *) type 'a t = | Nil : unit t | Cons : 'a * 'b t -> ('a * 'b) t val nil : unit t val cons : 'a -> 'b t -> ('a * 'b) t (** How to observe a {!'a t} *) type 'a obs val o_nil : unit obs val o_cons : 'a Observable.t -> 'b obs -> ('a * 'b) obs module Infix : sig val (@::) : 'a -> 'b t -> ('a * 'b) t (** Alias to {!cons}. *) val (@->) : 'a Observable.t -> 'b obs -> ('a * 'b) obs (** Alias to {!B_cons}. *) end include module type of Infix val observable : 'a obs -> 'a t Observable.t end val fun_nary : 'a Tuple.obs -> 'b arbitrary -> ('a Tuple.t -> 'b) fun_ arbitrary (** [fun_nary] makes random n-ary functions. Example: {[ let module O = Observable in fun_nary Tuple.(O.int @-> O.float @-> O.string @-> o_nil) bool) ]} @since 0.6 *) val fun2 : 'a Observable.t -> 'b Observable.t -> 'c arbitrary -> ('a -> 'b -> 'c) fun_ arbitrary (** @since 0.6 *) val fun3 : 'a Observable.t -> 'b Observable.t -> 'c Observable.t -> 'd arbitrary -> ('a -> 'b -> 'c -> 'd) fun_ arbitrary (** @since 0.6 *) val fun4 : 'a Observable.t -> 'b Observable.t -> 'c Observable.t -> 'd Observable.t -> 'e arbitrary -> ('a -> 'b -> 'c -> 'd -> 'e) fun_ arbitrary (** @since 0.6 *) val oneofl : ?print:'a Print.t -> ?collect:('a -> string) -> 'a list -> 'a arbitrary (** Pick an element randomly in the list. *) val oneofa : ?print:'a Print.t -> ?collect:('a -> string) -> 'a array -> 'a arbitrary (** Pick an element randomly in the array. *) val oneof : 'a arbitrary list -> 'a arbitrary (** Pick a generator among the list, randomly. *) val always : ?print:'a Print.t -> 'a -> 'a arbitrary (** Always return the same element. *) val frequency : ?print:'a Print.t -> ?small:('a -> int) -> ?shrink:'a Shrink.t -> ?collect:('a -> string) -> (int * 'a arbitrary) list -> 'a arbitrary (** Similar to {!oneof} but with frequencies. *) val frequencyl : ?print:'a Print.t -> ?small:('a -> int) -> (int * 'a) list -> 'a arbitrary (** Same as {!oneofl}, but each element is paired with its frequency in the probability distribution (the higher, the more likely). *) val frequencya : ?print:'a Print.t -> ?small:('a -> int) -> (int * 'a) array -> 'a arbitrary (** Same as {!frequencyl}, but with an array. *) val map : ?rev:('b -> 'a) -> ('a -> 'b) -> 'a arbitrary -> 'b arbitrary (** [map f a] returns a new arbitrary instance that generates values using [a#gen] and then transforms them through [f]. @param rev if provided, maps values back to type ['a] so that the printer, shrinker, etc. of [a] can be used. We assume [f] is monotonic in this case (that is, smaller inputs are transformed into smaller outputs). *) val map_same_type : ('a -> 'a) -> 'a arbitrary -> 'a arbitrary (** Specialization of [map] when the transformation preserves the type, which makes shrinker, printer, etc. still relevant. *) val map_keep_input : ?print:'b Print.t -> ?small:('b -> int) -> ('a -> 'b) -> 'a arbitrary -> ('a * 'b) arbitrary (** [map_keep_input f a] generates random values from [a], and maps them into values of type ['b] using the function [f], but it also keeps the original value. For shrinking, it is assumed that [f] is monotonic and that smaller input values will map into smaller values. @param print optional printer for the [f]'s output. *) qcheck-0.11/src/core/dune000066400000000000000000000002521354513211100152610ustar00rootroot00000000000000 (library (name qcheck_core) (public_name qcheck-core) (wrapped false) (libraries unix bytes) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) ) qcheck-0.11/src/dune000066400000000000000000000004151354513211100143320ustar00rootroot00000000000000 (library (name qcheck) (public_name qcheck) (wrapped false) (optional) (modules QCheck_runner) (synopsis "compatibility library for qcheck") (libraries qcheck-core qcheck-core.runner qcheck-ounit)) (documentation (package qcheck) (mld_files index)) qcheck-0.11/src/index.mld000066400000000000000000000006511354513211100152630ustar00rootroot00000000000000 {1 QCheck compatibility package} This library is there to ensure compatibility with QCheck 0.8 and earlier. It has a unique module {!QCheck_runner} that merges the custom runners from [qcheck-core.runner] ({!QCheck_base_runner}) and the OUnit runners from [qcheck-ounit] ({!QCheck_ounit}) into a single module. By depending on [qcheck-core], this library also brings {!QCheck} in scope, so it can be used transparently. qcheck-0.11/src/ounit/000077500000000000000000000000001354513211100146125ustar00rootroot00000000000000qcheck-0.11/src/ounit/QCheck_ounit.ml000066400000000000000000000161321354513211100175230ustar00rootroot00000000000000 open OUnit open QCheck_base_runner let ps = print_string let va = Printf.sprintf let pf = Printf.printf let not_success = function RSuccess _ -> false | _ -> true let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg let result_flavour = function | RError _ -> `Red, "Error" | RFailure _ -> `Red, "Failure" | RSuccess _ -> `Green, "Success" | RSkip _ -> `Blue, "Skip" | RTodo _ -> `Yellow, "Todo" let string_of_path path = let path = List.filter (function Label _ -> true | _ -> false) path in String.concat ">" (List.rev_map string_of_node path) let separator1 = "\027[K" ^ (String.make 79 '\\') let separator2 = String.make 79 '/' let print_result_list ~colors = List.iter (fun result -> let c, res = result_flavour result in pf "%s\n%a: %s\n\n%s\n%s\n" separator1 (Color.pp_str_c ~colors c) res (string_of_path (result_path result)) (result_msg result) separator2) let conf_seed = OUnit2.Conf.make_int "seed" ~-1 "set random seed" let conf_verbose = OUnit2.Conf.make_bool "qcheck_verbose" true "enable verbose QCheck tests" let conf_long = OUnit2.Conf.make_bool "qcheck_long" false "enable long QCheck tests" let default_rand () = (* random seed, for repeatability of tests *) Random.State.make [| 89809344; 994326685; 290180182 |] let to_ounit2_test ?(rand =default_rand()) (QCheck.Test.Test cell) = let module T = QCheck.Test in let name = T.get_name cell in let open OUnit2 in name >: test_case ~length:OUnitTest.Long (fun ctxt -> let rand = match conf_seed ctxt with | -1 -> Random.State.copy rand | s -> (* user provided random seed *) Random.State.make [| s |] in let verbose = conf_verbose ctxt in let long = conf_long ctxt in let print = { Raw. info = (fun fmt -> logf ctxt `Info fmt); fail = (fun fmt -> Printf.ksprintf assert_failure fmt); err = (fun fmt -> logf ctxt `Error fmt); } in T.check_cell_exn cell ~long ~rand ~call:(Raw.callback ~verbose ~print_res:true ~print)) let to_ounit2_test_list ?rand lst = List.rev (List.rev_map (to_ounit2_test ?rand) lst) (* to convert a test to a [OUnit.test], we register a callback that will possibly print errors and counter-examples *) let to_ounit_test_cell ?(verbose=verbose()) ?(long=long_tests()) ?(rand=random_state()) cell = let module T = QCheck.Test in let name = T.get_name cell in let run () = try T.check_cell_exn cell ~long ~rand ~call:(Raw.callback ~verbose ~print_res:verbose ~print:Raw.print_std); true with T.Test_fail _ -> false in name >:: (fun () -> assert_bool name (run ())) let to_ounit_test ?verbose ?long ?rand (QCheck.Test.Test c) = to_ounit_test_cell ?verbose ?long ?rand c let (>:::) name l = name >::: (List.map (fun t -> to_ounit_test t) l) (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in let res = f x y in (* evaluate this first *) Unix.gettimeofday () -. begin_time, res let run ?(argv=Sys.argv) test = let cli_args = Raw.parse_cli ~full_options:true argv in let colors = cli_args.Raw.cli_colors in (* print in colors *) let pp_color = Color.pp_str_c ~bold:true ~colors in let _counter = ref (0,0,0) in (* Success, Failure, Other *) let total_tests = test_case_count test in (* list of (test, execution time) *) let exec_times = ref [] in let update = function | RSuccess _ -> let (s,f,o) = !_counter in _counter := (succ s,f,o) | RFailure _ -> let (s,f,o) = !_counter in _counter := (s,succ f,o) | _ -> let (s,f,o) = !_counter in _counter := (s,f, succ o) in (* time each test *) let start = ref 0. and stop = ref 0. in (* display test as it starts and ends *) let display_test ?(ended=false) p = let (s,f,o) = !_counter in let cartouche = va " [%d%s%s / %d] " s (if f=0 then "" else va "+%d" f) (if o=0 then "" else va " %d!" o) total_tests and path = string_of_path p in let end_marker = if cli_args.Raw.cli_print_list then ( (* print a single line *) if ended then va " (after %.2fs)\n" (!stop -. !start) else "\n" ) else ( ps Color.reset_line; if ended then " *" else "" ) in let line = cartouche ^ path ^ end_marker in let remaining = 79 - String.length line in let cover = if remaining > 0 && not cli_args.Raw.cli_print_list then String.make remaining ' ' else "" in pf "%s%s%!" line cover; in let hdl_event = function | EStart p -> start := Unix.gettimeofday(); display_test p | EEnd p -> stop := Unix.gettimeofday(); display_test p ~ended:true; let exec_time = !stop -. !start in exec_times := (p, exec_time) :: !exec_times | EResult result -> update result in ps "Running tests..."; let running_time, results = time_fun perform_test hdl_event test in let (_s, f, o) = !_counter in let failures = List.filter not_success results in (* assert (List.length failures = f);*) ps Color.reset_line; print_result_list ~colors failures; assert (List.length results = total_tests); pf "Ran: %d tests in: %.2f seconds.%s\n" total_tests running_time (String.make 40 ' '); (* XXX: suboptimal, but should work fine *) if cli_args.Raw.cli_slow_test > 0 then ( pf "Display the %d slowest tests:\n" cli_args.Raw.cli_slow_test; let l = !exec_times in let l = List.sort (fun (_,t1)(_,t2) -> compare t2 t1) l in List.iteri (fun i (p,t) -> if i 0 then ( pf "%a SOME TESTS ARE NEITHER SUCCESSES NOR FAILURES!\n" (pp_color `Yellow) "WARNING!"; ); if failures <> [] then ( pf "%a\n" (pp_color `Red) "FAILURE"; ); (* create a meaningful return code for the process running the tests *) match f, o with | 0, 0 -> 0 | _ -> 1 (* TAP-compatible test runner, in case we want to use a test harness *) let run_tap test = let test_number = ref 0 in let handle_event = function | EStart _ | EEnd _ -> incr test_number | EResult (RSuccess p) -> pf "ok %d - %s\n%!" !test_number (string_of_path p) | EResult (RFailure (p,m)) -> pf "not ok %d - %s # %s\n%!" !test_number (string_of_path p) m | EResult (RError (p,m)) -> pf "not ok %d - %s # ERROR:%s\n%!" !test_number (string_of_path p) m | EResult (RSkip (p,m)) -> pf "not ok %d - %s # skip %s\n%!" !test_number (string_of_path p) m | EResult (RTodo (p,m)) -> pf "not ok %d - %s # todo %s\n%!" !test_number (string_of_path p) m in let total_tests = test_case_count test in pf "TAP version 13\n1..%d\n" total_tests; perform_test handle_event test qcheck-0.11/src/ounit/QCheck_ounit.mli000066400000000000000000000060441354513211100176750ustar00rootroot00000000000000 (** {1 Conversion of tests to OUnit Tests} @since 0.9 *) val to_ounit_test : ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> QCheck.Test.t -> OUnit.test (** [to_ounit_test ~rand t] wraps [t] into a OUnit test @param verbose used to print information on stdout (default: [verbose()]) @param rand the random generator to use (default: [random_state ()]) *) val to_ounit_test_cell : ?verbose:bool -> ?long:bool -> ?rand:Random.State.t -> _ QCheck.Test.cell -> OUnit.test (** Same as {!to_ounit_test} but with a polymorphic test cell *) val (>:::) : string -> QCheck.Test.t list -> OUnit.test (** Same as {!OUnit.>:::} but with a list of QCheck tests *) val to_ounit2_test : ?rand:Random.State.t -> QCheck.Test.t -> OUnit2.test (** [to_ounit2_test ?rand t] wraps [t] into a OUnit2 test @param rand the random generator to use (default: a static seed for reproducibility), can be overridden with "-seed" on the command-line *) val to_ounit2_test_list : ?rand:Random.State.t -> QCheck.Test.t list -> OUnit2.test list (** [to_ounit2_test_list ?rand t] like [to_ounit2_test] but for a list of tests *) (** {2 OUnit runners} QCheck provides some custom runners for OUnit tests. - {!run} is used by {{: https://github.com/vincent-hugot/qtest} qtest}. - {!run_tap} should be compatible with {{: https://en.wikipedia.org/wiki/Test_Anything_Protocol} TAP}. Note that {!OUnit.run_test_tt} or {!OUnit.run_test_tt_main} can be used as well, in particular when QCheck tests are mixed with normal unit tests. For OUnit2 you can use {!OUnit2.run_test_tt_main}. *) val run : ?argv:string array -> OUnit.test -> int (** [run test] runs the test, and returns an error code that is [0] if all tests passed, [1] otherwise. This is the default runner used by the comment-to-test generator. @param argv the command line arguments to parse parameters from (default [Sys.argv]) @raise Arg.Bad in case [argv] contains unknown arguments @raise Arg.Help in case [argv] contains "--help" This test runner displays execution in a compact way, making it good for suites that have lots of tests. Output example: {v random seed: 101121210 random seed: 101121210 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Error: tests>error_raise_exn test `error_raise_exn` raised exception `QCheck_ounit_test.Error` on `0 (after 62 shrink steps)` Raised at file "example/QCheck_ounit_test.ml", line 19, characters 20-25 Called from file "src/QCheck.ml", line 846, characters 13-33 /////////////////////////////////////////////////////////////////////////////// \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ Failure: tests>fail_sort_id fail_sort_id /////////////////////////////////////////////////////////////////////////////// Ran: 4 tests in: 0.74 seconds. WARNING! SOME TESTS ARE NEITHER SUCCESSES NOR FAILURES! v} *) val run_tap : OUnit.test -> OUnit.test_results (** TAP-compatible test runner, in case we want to use a test harness. It prints one line per test. *) qcheck-0.11/src/ounit/dune000066400000000000000000000003361354513211100154720ustar00rootroot00000000000000 (library (name qcheck_ounit) (public_name qcheck-ounit) (optional) (wrapped false) (libraries unix bytes qcheck-core qcheck-core.runner oUnit) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) ) qcheck-0.11/src/runner/000077500000000000000000000000001354513211100147655ustar00rootroot00000000000000qcheck-0.11/src/runner/QCheck_base_runner.ml000066400000000000000000000304321354513211100210420ustar00rootroot00000000000000(* QCheck: Random testing for OCaml copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard all rights reserved. *) let ps = print_string let va = Printf.sprintf let pf = Printf.printf module Color = struct let fpf = Printf.fprintf type color = [ `Red | `Yellow | `Green | `Blue | `Normal | `Cyan ] let int_of_color_ : color -> int = function | `Normal -> 0 | `Red -> 1 | `Green -> 2 | `Yellow -> 3 | `Blue -> 4 | `Cyan -> 6 (* same as [pp], but in color [c] *) let in_color c pp out x = let n = int_of_color_ c in fpf out "\x1b[3%dm" n; pp out x; fpf out "\x1b[0m" (* same as [pp], but in bold color [c] *) let in_bold_color c pp out x = let n = int_of_color_ c in fpf out "\x1b[3%d;1m" n; pp out x; fpf out "\x1b[0m" let reset_line = "\x1b[2K\r" let pp_str_c ?(bold=true) ~colors c out s = if colors then if bold then in_bold_color c output_string out s else in_color c output_string out s else output_string out s end let separator1 = "\027[K" ^ (String.make 79 '\\') let separator2 = String.make 79 '/' let seed = ref ~-1 let st = ref None let set_seed_ s = seed := s; Printf.printf "%srandom seed: %d\n%!" Color.reset_line s; let state = Random.State.make [| s |] in st := Some state; state (* time of last printed message. Useful for rate limiting in verbose mode *) let last_msg = ref 0. let time_between_msg = ref 0.1 let get_time_between_msg () = !time_between_msg let set_time_between_msg f = time_between_msg := f let set_seed s = ignore (set_seed_ s) let setup_random_state_ () = let s = if !seed = ~-1 then ( Random.self_init (); (* make new, truly random seed *) Random.int (1 lsl 29); ) else !seed in set_seed_ s (* initialize random generator from seed (if any) *) let random_state () = match !st with | Some st -> st | None -> setup_random_state_ () let verbose, set_verbose = let r = ref false in (fun () -> !r), (fun b -> r := b) let long_tests, set_long_tests = let r = ref false in (fun () -> !r), (fun b -> r := b) module Raw = struct type ('b,'c) printer = { info: 'a. ('a,'b,'c,unit) format4 -> 'a; fail: 'a. ('a,'b,'c,unit) format4 -> 'a; err: 'a. ('a,'b,'c,unit) format4 -> 'a; } type cli_args = { cli_verbose : bool; cli_long_tests : bool; cli_print_list : bool; cli_rand : Random.State.t; cli_slow_test : int; (* how many slow tests to display? *) cli_colors: bool; } (* main callback for individual tests @param verbose if true, print statistics and details @param print_res if true, print the result on [out] *) let callback ~verbose ~print_res ~print name cell result = let module R = QCheck.TestResult in let module T = QCheck.Test in let arb = T.get_arbitrary cell in if verbose then ( print.info "%slaw %s: %d relevant cases (%d total)\n" Color.reset_line name result.R.count result.R.count_gen; begin match QCheck.TestResult.collect result with | None -> () | Some tbl -> print_string (QCheck.Test.print_collect tbl) end; ); if print_res then ( (* even if [not verbose], print errors *) match result.R.state with | R.Success -> () | R.Failed {instances=l} -> print.fail "%s%s\n" Color.reset_line (T.print_fail arb name l); | R.Failed_other {msg} -> print.fail "%s%s\n" Color.reset_line (T.print_fail_other name ~msg); | R.Error {instance; exn; backtrace} -> print.err "%s%s\n" Color.reset_line (T.print_error ~st:backtrace arb name (instance,exn)); ) let print_std = { info = Printf.printf; fail = Printf.printf; err = Printf.printf } let parse_cli ~full_options argv = let print_list = ref false in let set_verbose () = set_verbose true in let set_long_tests () = set_long_tests true in let set_backtraces () = Printexc.record_backtrace true in let set_list () = print_list := true in let colors = ref true in let slow = ref 0 in let options = Arg.align ( [ "-v", Arg.Unit set_verbose, " " ; "--verbose", Arg.Unit set_verbose, " enable verbose tests" ; "--colors", Arg.Set colors, " colored output" ; "--no-colors", Arg.Clear colors, " disable colored output" ] @ (if full_options then [ "-l", Arg.Unit set_list, " " ; "--list", Arg.Unit set_list, " print list of tests (2 lines each)" ; "--slow", Arg.Set_int slow, " print the slowest tests" ] else [] ) @ [ "-s", Arg.Set_int seed, " " ; "--seed", Arg.Set_int seed, " set random seed (to repeat tests)" ; "--long", Arg.Unit set_long_tests, " run long tests" ; "-bt", Arg.Unit set_backtraces, " enable backtraces" ] ) in Arg.parse_argv argv options (fun _ ->()) "run qtest suite"; let cli_rand = setup_random_state_ () in { cli_verbose=verbose(); cli_long_tests=long_tests(); cli_rand; cli_print_list= !print_list; cli_slow_test= !slow; cli_colors= !colors; } end open Raw (* Counter for a test's instances *) type counter = { start : float; expected : int; mutable gen : int; mutable passed : int; mutable failed : int; mutable errored : int; } type res = | Res : 'a QCheck.Test.cell * 'a QCheck.TestResult.t -> res let pp_counter ~size out c = let t = Unix.gettimeofday () -. c.start in Printf.fprintf out "%*d %*d %*d %*d / %*d %7.1fs" size c.gen size c.errored size c.failed size c.passed size c.expected t let handler ~size ~out ~verbose c name _ r = let st = function | QCheck.Test.Generating -> "generating" | QCheck.Test.Collecting _ -> "collecting" | QCheck.Test.Testing _ -> " testing" | QCheck.Test.Shrunk (i, _) -> Printf.sprintf "shrinking: %4d" i | QCheck.Test.Shrinking (i, j, _) -> Printf.sprintf "shrinking: %4d.%04d" i j in (* use timestamps for rate-limiting *) let now=Unix.gettimeofday() in if verbose && now -. !last_msg > get_time_between_msg () then ( last_msg := now; Printf.fprintf out "%s[ ] %a %s (%s)%!" Color.reset_line (pp_counter ~size) c name (st r) ) let step ~size ~out ~verbose c name _ _ r = let aux = function | QCheck.Test.Success -> c.passed <- c.passed + 1 | QCheck.Test.Failure -> c.failed <- c.failed + 1 | QCheck.Test.FalseAssumption -> () | QCheck.Test.Error _ -> c.errored <- c.errored + 1 in c.gen <- c.gen + 1; aux r; let now=Unix.gettimeofday() in if verbose && now -. !last_msg > get_time_between_msg () then ( last_msg := now; Printf.fprintf out "%s[ ] %a %s%!" Color.reset_line (pp_counter ~size) c name ) let callback ~size ~out ~verbose ~colors c name _ _ = let pass = c.failed = 0 && c.errored = 0 in let color = if pass then `Green else `Red in if verbose then ( Printf.fprintf out "%s[%a] %a %s\n%!" Color.reset_line (Color.pp_str_c ~bold:true ~colors color) (if pass then "✓" else "✗") (pp_counter ~size) c name ) let print_inst arb x = match arb.QCheck.print with | Some f -> f x | None -> "" let expect long cell = let count = QCheck.Test.get_count cell in if long then QCheck.Test.get_long_factor cell * count else count let expect_size long cell = let rec aux n = if n < 10 then 1 else 1 + (aux (n / 10)) in aux (expect long cell) (* print user messages for a test *) let print_messages ~colors out cell l = if l<>[] then ( Printf.fprintf out "\n+++ %a %s\n\nMessages for test %s:\n\n%!" (Color.pp_str_c ~colors `Blue) "Messages" (String.make 68 '+') (QCheck.Test.get_name cell); List.iter (Printf.fprintf out "%s\n%!") l ) let print_success ~colors out cell r = begin match QCheck.TestResult.collect r with | None -> () | Some tbl -> Printf.fprintf out "\n+++ %a %s\n\nCollect results for test %s:\n\n%s%!" (Color.pp_str_c ~colors `Blue) "Collect" (String.make 68 '+') (QCheck.Test.get_name cell) (QCheck.Test.print_collect tbl) end; List.iter (fun msg -> Printf.fprintf out "\n!!! %a %s\n\nWarning for test %s:\n\n%s%!" (Color.pp_str_c ~colors `Yellow) "Warning" (String.make 68 '!') (QCheck.Test.get_name cell) msg) (QCheck.TestResult.warnings r); List.iter (fun st -> Printf.fprintf out "\n+++ %a %s\n\nStat for test %s:\n\n%s%!" (Color.pp_str_c ~colors `Blue) "Stat" (String.make 68 '+') (QCheck.Test.get_name cell) (QCheck.Test.print_stat st)) (QCheck.TestResult.stats r); () let print_fail ~colors out cell c_ex = Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-'); Printf.fprintf out "Test %s failed (%d shrink steps):\n\n%s\n%!" (QCheck.Test.get_name cell) c_ex.QCheck.TestResult.shrink_steps (print_inst (QCheck.Test.get_arbitrary cell) c_ex.QCheck.TestResult.instance); print_messages ~colors out cell c_ex.QCheck.TestResult.msg_l let print_fail_other ~colors out cell msg = Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-'); Printf.fprintf out "Test %s failed:\n\n%s\n%!" (QCheck.Test.get_name cell) msg let print_error ~colors out cell c_ex exn bt = Printf.fprintf out "\n=== %a %s\n\n" (Color.pp_str_c ~colors `Red) "Error" (String.make 70 '='); Printf.fprintf out "Test %s errored on (%d shrink steps):\n\n%s\n\nexception %s\n%s\n%!" (QCheck.Test.get_name cell) c_ex.QCheck.TestResult.shrink_steps (print_inst (QCheck.Test.get_arbitrary cell) c_ex.QCheck.TestResult.instance) (Printexc.to_string exn) bt; print_messages ~colors out cell c_ex.QCheck.TestResult.msg_l let run_tests ?(colors=true) ?(verbose=verbose()) ?(long=long_tests()) ?(out=stdout) ?(rand=random_state()) l = let module T = QCheck.Test in let module R = QCheck.TestResult in let pp_color = Color.pp_str_c ~bold:true ~colors in let size = List.fold_left (fun acc (T.Test cell) -> max acc (expect_size long cell)) 4 l in if verbose then Printf.fprintf out "%*s %*s %*s %*s / %*s time test name\n%!" (size + 4) "generated" size "error" size "fail" size "pass" size "total"; let aux_map (T.Test cell) = let expected = expect long cell in let start = Unix.gettimeofday () in let c = { start; expected; gen = 0; passed = 0; failed = 0; errored = 0; } in if verbose then Printf.fprintf out "%s[ ] %a %s%!" Color.reset_line (pp_counter ~size) c (T.get_name cell); let r = QCheck.Test.check_cell ~long ~rand ~handler:(handler ~size ~out ~verbose c) ~step:(step ~size ~out ~verbose c) ~call:(callback ~size ~out ~verbose ~colors c) cell in Res (cell, r) in let res = List.map aux_map l in let aux_fold (total, fail, error, warns) (Res (cell, r)) = let warns = warns + List.length r.R.warnings in let acc = match r.R.state with | R.Success -> print_success ~colors out cell r; (total + 1, fail, error, warns) | R.Failed {instances=l} -> List.iter (print_fail ~colors out cell) l; (total + 1, fail + 1, error, warns) | R.Failed_other {msg} -> print_fail_other ~colors out cell msg; (total + 1, fail + 1, error, warns) | R.Error {instance=c_ex; exn; backtrace=bt} -> print_error ~colors out cell c_ex exn bt; (total + 1, fail, error + 1, warns) in acc in let total, fail, error, warns = List.fold_left aux_fold (0, 0, 0,0) res in Printf.fprintf out "%s\n" (String.make 80 '='); if warns > 0 then Printf.fprintf out "%d warning(s)\n" warns; if fail = 0 && error = 0 then ( Printf.fprintf out "%a (ran %d tests)\n%!" (pp_color `Green) "success" total; 0 ) else ( Printf.fprintf out "%a (%d tests failed, %d tests errored, ran %d tests)\n%!" (pp_color `Red) "failure" fail error total; 1 ) let run_tests_main ?(argv=Sys.argv) l = try let cli_args = parse_cli ~full_options:false argv in exit (run_tests l ~colors:cli_args.cli_colors ~verbose:cli_args.cli_verbose ~long:cli_args.cli_long_tests ~out:stdout ~rand:cli_args.cli_rand) with | Arg.Bad msg -> print_endline msg; exit 1 | Arg.Help msg -> print_endline msg; exit 0 qcheck-0.11/src/runner/QCheck_base_runner.mli000066400000000000000000000116061354513211100212150ustar00rootroot00000000000000(* QCheck: Random testing for OCaml copyright (c) 2013-2017, Guillaume Bury, Simon Cruanes, Vincent Hugot, Jan Midtgaard all rights reserved. *) (** {1 Runners for Tests} Once you built some tests using {!QCheck.Test.make}, you need to run the tests. This module contains several {b runners}, which are designed to run every test and report the result. By default, you can use {!run_tests} in a test program as follows: {[ let testsuite = [ Test.make ...; Test.make ...; ] let () = let errcode = QCheck_runners.run_tests ~verbose:true testsuite in exit errcode ]} which will run the tests, and exit the program. The error code will be 0 if all tests pass, 1 otherwise. {!run_tests_main} can be used as a shortcut for that, also featuring command-line parsing (using {!Arg}) to activate verbose mode and others. *) (** {2 State} *) val random_state : unit -> Random.State.t (** Access the current random state *) val verbose : unit -> bool (** Is the default mode verbose or quiet? *) val long_tests : unit -> bool (** Is the default mode to run long tests or nor? *) val set_seed : int -> unit (** Change the {!random_state} by creating a new one, initialized with the given seed. *) val set_verbose : bool -> unit (** Change the value of [verbose ()] *) val set_long_tests : bool -> unit (** Change the value of [long_tests ()] *) val get_time_between_msg : unit -> float (** Get the minimum time to wait between printing messages. @since 0.9 *) val set_time_between_msg : float -> unit (** Set the minimum tiem between messages. @since 0.9 *) (** {2 Run a Suite of Tests and Get Results} *) val run_tests : ?colors:bool -> ?verbose:bool -> ?long:bool -> ?out:out_channel -> ?rand:Random.State.t -> QCheck.Test.t list -> int (** Run a suite of tests, and print its results. This is an heritage from the "qcheck" library. @return an error code, [0] if all tests passed, [1] otherwise. @param colors if true, colorful output @param verbose if true, prints more information about test cases *) val run_tests_main : ?argv:string array -> QCheck.Test.t list -> 'a (** Can be used as the main function of a test file. Exits with a non-0 code if the tests fail. It refers to {!run_tests} for actually running tests after CLI options have been parsed. The available options are: - "--verbose" (or "-v") for activating verbose tests - "--seed " (or "-s ") for repeating a previous run by setting the random seed - "--long" for running the long versions of the tests Below is an example of the output of the [run_tests] and [run_tests_main] function: {v random seed: 438308050 generated error; fail; pass / total - time -- test name [✓] (1000) 0 ; 0 ; 1000 / 1000 -- 0.5s -- list_rev_is_involutive [✗] ( 1) 0 ; 1 ; 0 / 10 -- 0.0s -- should_fail_sort_id [✗] ( 1) 1 ; 0 ; 0 / 10 -- 0.0s -- should_error_raise_exn [✓] (1000) 0 ; 0 ; 1000 / 1000 -- 0.0s -- collect_results --- Failure -------------------------------------------------------------------- Test should_fail_sort_id failed (11 shrink steps): [1; 0] === Error ====================================================================== Test should_error_raise_exn errored on (62 shrink steps): 0 exception QCheck_runner_test.Error Raised at file "example/QCheck_runner_test.ml", line 20, characters 20-25 Called from file "src/QCheck.ml", line 839, characters 13-33 +++ Collect ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Collect results for test collect_results: 4: 207 cases 3: 190 cases 2: 219 cases 1: 196 cases 0: 188 cases ================================================================================ failure (1 tests failed, 1 tests errored, ran 4 tests) v} *) (** {2 Utils for colored output} *) module Color : sig type color = [ `Red | `Yellow | `Green | `Blue | `Normal | `Cyan ] val reset_line : string val pp_str_c : ?bold:bool -> colors:bool -> color -> out_channel -> string -> unit end (** {2 Internal Utils} We provide {b NO} stability guarantee for this module. Use at your own risks. *) module Raw : sig type ('b,'c) printer = { info: 'a. ('a,'b,'c,unit) format4 -> 'a; fail: 'a. ('a,'b,'c,unit) format4 -> 'a; err: 'a. ('a,'b,'c,unit) format4 -> 'a; } val print_std : (out_channel, unit) printer (* main callback for display *) val callback : verbose:bool -> print_res:bool -> print:('a, 'b) printer -> string -> 'c QCheck.Test.cell -> 'c QCheck.TestResult.t -> unit type cli_args = { cli_verbose : bool; cli_long_tests : bool; cli_print_list : bool; cli_rand : Random.State.t; cli_slow_test : int; (* how many slow tests to display? *) cli_colors: bool; } val parse_cli : full_options:bool -> string array -> cli_args end qcheck-0.11/src/runner/dune000066400000000000000000000002641354513211100156450ustar00rootroot00000000000000 (library (name qcheck_runner) (public_name qcheck-core.runner) (wrapped false) (libraries qcheck-core) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) )