Commit 34388d0adf98771c32469e6fa3c6dbfe4285900e - ocaml-qcheck

New upstream version 0.11 Andy Li 4 years ago

15 changed file(s) with 508 addition(s) and 150 deletion(s). Raw diff Collapse all Expand all

-5

.travis.yml less more

6	6	global:
7	7	- PINS="qcheck:. qcheck-core:. qcheck-ounit:. qcheck-alcotest:."
8	8	- DISTRO="ubuntu-16.04"
	9	- PACKAGE="qcheck"
	10	- DEPOPTS="ounit alcotest"
9	11	matrix:
10		- PACKAGE="qcheck" OCAML_VERSION="4.03.0" DEPOPTS="ounit alcotest"
11		- PACKAGE="qcheck" OCAML_VERSION="4.04.2" DEPOPTS="ounit alcotest"
12		- PACKAGE="qcheck" OCAML_VERSION="4.05.0" DEPOPTS="ounit alcotest"
13		- PACKAGE="qcheck" OCAML_VERSION="4.06.0" DEPOPTS="ounit alcotest"
14		- PACKAGE="qcheck" OCAML_VERSION="4.07.0" DEPOPTS="ounit alcotest"
	12	- OCAML_VERSION="4.03"
	13	- OCAML_VERSION="4.04"
	14	- OCAML_VERSION="4.05"
	15	- OCAML_VERSION="4.06"
	16	- OCAML_VERSION="4.07"
	17	- OCAML_VERSION="4.08"
	18	- OCAML_VERSION="4.09"

+23

-0

CHANGELOG.md less more

0	0	# Changes
	1
	2	## 0.11
	3
	4	- Add `QCheck.Gen.{string_of,string_readable}`
	5	- fix `int_bound` bound inclusiveness problem
	6	- change implementation of `int_bound` to generate values using `Random.State.int` for `bound < 2^30`
	7	- add weighted shuffled lists generator
	8	- add `float_range` to generate a floating-point number in the given range (inclusive)
	9	- add `float_bound_inclusive` and `float_bound_exclusive` to generate floating-point numbers between 0 and a given bound
	10
	11	## 0.10
	12
	13	- `Shrink`: decompose Shrink.list into Shrink.list_spine and Shrink.list_elems
	14	- `Gen.fix` has a more general and useful type
	15	- update README to include `Rely` section (qcheck now available for reason-native!)
	16	- Fix stat printing
	17	- speed-up list shrinker
	18	- Better int shrinking
	19	- core: modify proba distributions again, add `big_nat`
	20	- feat: add `small_array`, modify distributions
	21	- print number of warnings in runner's summary
	22	- refactor: modify type of results to make them more accurate
	23	- feat: warn/fail if too many tests passed only b/c precondition failed
1	24
2	25	## 0.9
3	26

-1

Makefile less more

34	34	release: update_next_tag
35	35	@echo "release version $(VERSION)..."
36	36	git tag -f $(VERSION) ; git push origin :$(VERSION) ; git push origin $(VERSION)
37		opam publish prepare https://github.com/c-cube/qcheck/archive/$(VERSION).tar.gz
	37	opam publish https://github.com/c-cube/qcheck/archive/$(VERSION).tar.gz
38	38	@echo "review the release, then type 'opam publish submit qcheck.$(VERSION)/'"
39	39
40	40

+42

-3

README.adoc less more

11	11	https://github.com/vincent-hugot/iTeML[qtest], but is now
12	12	standalone again!
13	13	Note that @gasche's
14		http://gasche.github.io/random-generator/doc/Generator.html[generator library]
	14	https://github.com/gasche/random-generator/[generator library]
15	15	can be useful too, for generating random values.
16	16
17	17	toc::[]

21	21	== Use
22	22
23	23	See the documentation. I also wrote
24		http://cedeela.fr/quickcheck-for-ocaml.html[a blog post] that explains
	24	https://cedeela.fr/quickcheck-for-ocaml[a blog post] that explains
25	25	how to use it and some design choices; however, be warned that the API
26	26	changed in lots of small ways (in the right direction, I hope) so the code
27	27	will not work any more.

185	185	- a printer (optional), very useful for printing counterexamples
186	186	- a shrinker (optional), very useful for trying to reduce big
187	187	counterexamples to small counterexamples that are usually
188		more easy to understand.
	188	more easy to understand.
189	189
190	190	The above shrinker strategy is to
191	191

356	356
357	357	----
358	358
	359	=== Integration within Rely
	360	https://reason-native.com/docs/rely/[Rely] is a Jest-inspire native reason testing framework.
	361	@reason-native/qcheck-rely is available via NPM and provides matchers for the easy
	362	use of qCheck within Rely.
	363
	364	[source, Reason]
	365	----
	366	open TestFramework;
	367	open QCheckRely;
	368
	369	let {describe} = extendDescribe(QCheckRely.Matchers.matchers);
	370
	371	describe("qcheck-rely", ({test}) => {
	372	test("passing test", ({expect}) => {
	373	let passing =
	374	QCheck.Test.make(
	375	~count=1000,
	376	~name="list_rev_is_involutive",
	377	QCheck.(list(small_int)),
	378	l =>
	379	List.rev(List.rev(l)) == l
	380	);
	381	expect.ext.qCheckTest(passing);
	382	();
	383	});
	384	test("failing test", ({expect}) => {
	385	let failing =
	386	QCheck.Test.make(
	387	~count=10, ~name="fail_sort_id", QCheck.(list(small_int)), l =>
	388	l == List.sort(compare, l)
	389	);
	390
	391	expect.ext.qCheckTest(failing);
	392	();
	393	});
	394	});
	395
	396	----
	397
359	398	=== Compatibility notes
360	399
361	400	Starting with 0.9, the library is split into several components:

+18

-0

example/QCheck_runner_test.ml less more

51	51	QCheck.(fun1 Observable.string bool)
52	52	(fun (QCheck.Fun (_,p)) ->
53	53	not (p "some random string") \|\| p "some other string")
	54
	55	let bad_assume_warn =
	56	QCheck.Test.make ~count:2_000
	57	~name:"WARN_unlikely_precond"
	58	QCheck.int
	59	(fun x ->
	60	QCheck.assume (x mod 100 = 1);
	61	true)
	62
	63	let bad_assume_fail =
	64	QCheck.Test.make ~count:2_000 ~if_assumptions_fail:(`Fatal, 0.1)
	65	~name:"FAIL_unlikely_precond"
	66	QCheck.int
	67	(fun x ->
	68	QCheck.assume (x mod 100 = 1);
	69	true)
54	70
55	71	let int_gen = QCheck.small_nat (* int *)
56	72

138	154	find_ex;
139	155	shrink_int;
140	156	stats_negs;
	157	bad_assume_warn;
	158	bad_assume_fail;
141	159	] @ stats_tests)
142	160

+13

-15

qcheck-alcotest.opam less more

0		opam-version: "1.2"
	0	opam-version: "2.0"
1	1	maintainer: "simon.cruanes.2007@m4x.org"
2		author: [ "Simon Cruanes <simon.cruanes.2007@m4x.orgr>" ]
	2	author: [ "Simon Cruanes <simon.cruanes.2007@m4x.org>" ]
3	3	homepage: "https://github.com/c-cube/qcheck/"
	4	synopsis: "Alcotest backend for qcheck"
4	5	doc: ["http://c-cube.github.io/qcheck/"]
5		version: "0.9"
	6	version: "0.11"
6	7	tags: [
7	8	"test"
8		"property"
9	9	"quickcheck"
	10	"qcheck"
	11	"alcotest"
10	12	]
11	13	build: [
12	14	["dune" "build" "-p" name "-j" jobs]
13		]
14		build-doc: [
15		["dune" "build" "@doc" "-p" name]
16		]
17		build-test: [
18		["dune" "runtest" "-p" name]
	15	["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
	16	["dune" "runtest" "-p" name "-j" jobs] {with-test}
19	17	]
20	18	depends: [
21		"dune" {build}
	19	"dune"
22	20	"base-bytes"
23	21	"base-unix"
24		"qcheck-core" { >= "0.9" }
	22	"qcheck-core" { = version }
25	23	"alcotest"
26		"odoc" {doc}
	24	"odoc" {with-doc}
	25	"ocaml" {>= "4.03.0"}
27	26	]
28		available: [ ocaml-version >= "4.03.0" ]
29		dev-repo: "https://github.com/c-cube/qcheck.git"
	27	dev-repo: "git+https://github.com/c-cube/qcheck.git"
30	28	bug-reports: "https://github.com/c-cube/qcheck/issues"

+10

-13

qcheck-core.opam less more

0		opam-version: "1.2"
	0	opam-version: "2.0"
1	1	maintainer: "simon.cruanes.2007@m4x.org"
2		author: [ "Simon Cruanes <simon.cruanes.2007@m4x.orgr>" ]
	2	author: [ "Simon Cruanes <simon.cruanes.2007@m4x.org>" ]
3	3	homepage: "https://github.com/c-cube/qcheck/"
	4	synopsis: "Core qcheck library"
4	5	doc: ["http://c-cube.github.io/qcheck/"]
5		version: "0.9"
	6	version: "0.11"
6	7	tags: [
7	8	"test"
8	9	"property"

10	11	]
11	12	build: [
12	13	["dune" "build" "-p" name "-j" jobs]
13		]
14		build-doc: [
15		["dune" "build" "@doc" "-p" name]
16		]
17		build-test: [
18		["dune" "runtest" "-p" name]
	14	["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
	15	["dune" "runtest" "-p" name "-j" jobs] {with-test}
19	16	]
20	17	depends: [
21		"dune" {build}
	18	"dune"
22	19	"base-bytes"
23	20	"base-unix"
24		"odoc" {doc}
	21	"odoc" {with-doc}
	22	"ocaml" {>= "4.03.0"}
25	23	]
26		available: [ ocaml-version >= "4.03.0" ]
27		dev-repo: "https://github.com/c-cube/qcheck.git"
	24	dev-repo: "git+https://github.com/c-cube/qcheck.git"
28	25	bug-reports: "https://github.com/c-cube/qcheck/issues"
29	26	conflicts: [
30	27	"ounit" { < "2.0" }

+13

-16

qcheck-ounit.opam less more

0		opam-version: "1.2"
	0	opam-version: "2.0"
1	1	maintainer: "simon.cruanes.2007@m4x.org"
2		author: [ "Simon Cruanes <simon.cruanes.2007@m4x.orgr>" ]
	2	author: [ "Simon Cruanes <simon.cruanes.2007@m4x.org>" ]
3	3	homepage: "https://github.com/c-cube/qcheck/"
4	4	doc: ["http://c-cube.github.io/qcheck/"]
5		version: "0.9"
	5	synopsis: "OUnit backend for qcheck"
	6	version: "0.11"
6	7	tags: [
7		"test"
8		"property"
	8	"qcheck"
9	9	"quickcheck"
	10	"ounit"
10	11	]
11	12	build: [
12	13	["dune" "build" "-p" name "-j" jobs]
13		]
14		build-doc: [
15		["dune" "build" "@doc" "-p" name]
16		]
17		build-test: [
18		["dune" "runtest" "-p" name]
	14	["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
	15	["dune" "runtest" "-p" name "-j" jobs] {with-test}
19	16	]
20	17	depends: [
21		"dune" {build}
	18	"dune"
22	19	"base-bytes"
23	20	"base-unix"
24		"qcheck-core" { >= "0.9" }
	21	"qcheck-core" { = version }
25	22	"ounit" {>= "2.0"}
26		"odoc" {doc}
	23	"odoc" {with-doc}
	24	"ocaml" {>= "4.03.0"}
27	25	]
28		available: [ ocaml-version >= "4.03.0" ]
29		dev-repo: "https://github.com/c-cube/qcheck.git"
	26	dev-repo: "git+https://github.com/c-cube/qcheck.git"
30	27	bug-reports: "https://github.com/c-cube/qcheck/issues"

+12

-15

qcheck.opam less more

0		opam-version: "1.2"
	0	opam-version: "2.0"
1	1	maintainer: "simon.cruanes.2007@m4x.org"
2		author: [ "Simon Cruanes <simon.cruanes.2007@m4x.orgr>" ]
	2	author: [ "Simon Cruanes <simon.cruanes.2007@m4x.org>" ]
	3	synopsis: "Compatibility package for qcheck"
3	4	homepage: "https://github.com/c-cube/qcheck/"
4	5	doc: ["http://c-cube.github.io/qcheck/"]
5		version: "0.9"
	6	version: "0.11"
6	7	tags: [
7	8	"test"
8	9	"property"

10	11	]
11	12	build: [
12	13	["dune" "build" "-p" name "-j" jobs]
13		]
14		build-doc: [
15		["dune" "build" "@doc" "-p" name]
16		]
17		build-test: [
18		["dune" "runtest" "-p" name]
	14	["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
	15	["dune" "runtest" "-p" name "-j" jobs] {with-test}
19	16	]
20	17	depends: [
21		"dune" {build}
	18	"dune"
22	19	"base-bytes"
23	20	"base-unix"
24		"qcheck-core" { >= "0.9" }
25		"qcheck-ounit" { >= "0.9" }
26		"odoc" {doc}
	21	"qcheck-core" { = version }
	22	"qcheck-ounit" { = version }
	23	"odoc" {with-doc}
	24	"ocaml" {>= "4.03.0"}
27	25	]
28		available: [ ocaml-version >= "4.03.0" ]
29		dev-repo: "https://github.com/c-cube/qcheck.git"
	26	dev-repo: "git+https://github.com/c-cube/qcheck.git"
30	27	bug-reports: "https://github.com/c-cube/qcheck/issues"
31	28	conflicts: [
32	29	"ounit" { < "2.0" }

-3

src/alcotest/QCheck_alcotest.mli less more

3	3	We use environment variables for controlling QCheck here, since alcotest
4	4	doesn't seem to provide a lot of flexibility.
5	5
6		[QCHECK_VERBOSE] if "1" or "true", will make tests verbose
7		[QCHECK_SEED] if an integer, will fix the seed
8		[QCHECK_LONG] is present, will trigger long tests
	6	- [QCHECK_VERBOSE] if "1" or "true", will make tests verbose
	7	- [QCHECK_SEED] if an integer, will fix the seed
	8	- [QCHECK_LONG] is present, will trigger long tests
9	9
10	10	@since 0.9
11	11	*)

+193

-48

src/core/QCheck.ml less more

93	93
94	94	let frequency l st = frequencyl l st st
95	95
	96	let small_nat st =
	97	let p = RS.float st 1. in
	98	if p < 0.75 then RS.int st 10 else RS.int st 100
	99
96	100	(* natural number generator *)
97	101	let nat st =
98	102	let p = RS.float st 1. in

101	105	else if p < 0.95 then RS.int st 1_000
102	106	else RS.int st 10_000
103	107
104		let small_nat = nat
	108	let big_nat st =
	109	let p = RS.float st 1. in
	110	if p < 0.75 then nat st
	111	else RS.int st 1_000_000
105	112
106	113	let unit _st = ()
107	114

113	120
114	121	let pfloat st = abs_float (float st)
115	122	let nfloat st = -.(pfloat st)
	123
	124	let float_bound_inclusive bound st = RS.float st bound
	125
	126	let float_bound_exclusive bound st =
	127	match bound with
	128	\| 0. -> raise (Invalid_argument "Gen.float_bound_exclusive")
	129	\| b_pos when bound > 0. -> RS.float st (b_pos -. epsilon_float)
	130	\| b_neg -> RS.float st (b_neg +. epsilon_float)
	131
	132	let float_range low high =
	133	if high < low \|\| high -. low > max_float then invalid_arg "Gen.float_range";
	134	fun st -> low +. (float_bound_inclusive (high -. low) st)
	135
	136	let (--.) = float_range
116	137
117	138	let neg_int st = -(nat st)
118	139

134	155	let int st = if RS.bool st then - (pint st) - 1 else pint st
135	156	let int_bound n =
136	157	if n < 0 then invalid_arg "Gen.int_bound";
137		fun st ->
138		let r = pint st in
139		r mod (n+1)
	158	if n <= (1 lsl 30) - 2
	159	then fun st -> Random.State.int st (n + 1)
	160	else fun st -> let r = pint st in r mod (n + 1)
140	161	let int_range a b =
141	162	if b < a then invalid_arg "Gen.int_range";
142	163	fun st -> a + (int_bound (b-a) st)

187	208	shuffle_a a st;
188	209	Array.to_list a
189	210
	211	let shuffle_w_l l st =
	212	let sample (w, v) =
	213	let fl_w = float_of_int w in
	214	(float_bound_inclusive 1. st ** (1. /. fl_w), v)
	215	in
	216	let samples = List.rev_map sample l in
	217	List.sort (fun (w1, _) (w2, _) -> compare w1 w2) samples \|> List.rev_map snd
	218
190	219	let pair g1 g2 st = (g1 st, g2 st)
191	220
192	221	let triple g1 g2 g3 st = (g1 st, g2 st, g3 st)

213	242	Bytes.set s i (gen st)
214	243	done;
215	244	Bytes.unsafe_to_string s
216		let string ?gen st = string_size ?gen small_nat st
217		let small_string ?gen st = string_size ?gen (0--10) st
218		let small_list gen = list_size (0--10) gen
	245	let string ?gen st = string_size ?gen nat st
	246	let string_of gen = string_size ~gen nat
	247	let string_readable = string_size ~gen:char nat
	248	let small_string ?gen st = string_size ?gen small_nat st
	249	let small_list gen = list_size small_nat gen
	250	let small_array gen = array_size small_nat gen
219	251
220	252	let join g st = (g st) st
221	253

324	356	type 'a t = 'a -> 'a Iter.t
325	357
326	358	let nil _ = Iter.empty
	359
327	360	let unit = nil
328	361
329	362	(* balanced shrinker for integers (non-exhaustive) *)
330	363	let int x yield =
331	364	let y = ref x in
332	365	(* try some divisors *)
333		while !y < -2 \|\| !y >2 do y := !y / 2; yield !y; done; (* fast path *)
	366	while !y < -2 \|\| !y >2 do y := !y / 2; yield (x - !y); done; (* fast path *)
334	367	if x>0 then yield (x-1);
335	368	if x<0 then yield (x+1);
336	369	()
337	370
338	371	(* aggressive shrinker for integers,
339		get closer to 0, by dichotomy or just enumerating smaller values *)
	372	get from 0 to x, by dichotomy or just enumerating smaller values *)
340	373	let int_aggressive x yield =
341	374	let y = ref x in
342		while !y < -2 \|\| !y >2 do y := !y / 2; yield !y; done; (* fast path *)
	375	while !y < -2 \|\| !y >2 do y := !y / 2; yield (x - !y); done; (* fast path *)
343	376	if x>0 then for i=x-1 downto 0 do yield i done;
344	377	if x<0 then for i=x+1 to 0 do yield i done
345	378

385	418	)
386	419	done
387	420
	421	let list_spine l yield =
	422	let n = List.length l in
	423	let chunk_size = ref (n/2) in
	424
	425	(* push the [n] first elements of [l] into [q], return the rest of the list *)
	426	let rec fill_queue n l q = match n,l with
	427	\| 0, _ -> l
	428	\| _, x::xs ->
	429	Queue.push x q;
	430	fill_queue (n-1) xs q
	431	\| _, _ -> assert false
	432	in
	433
	434	(* remove elements from the list, by chunks of size [chunk_size] (bigger
	435	chunks first) *)
	436	while !chunk_size > 0 do
	437	let q = Queue.create () in
	438	let l' = fill_queue !chunk_size l q in
	439	(* remove [chunk_size] elements in queue *)
	440	let rec pos_loop rev_prefix suffix =
	441	yield (List.rev_append rev_prefix suffix);
	442	match suffix with
	443	\| [] -> ()
	444	\| x::xs ->
	445	Queue.push x q;
	446	let y = Queue.pop q in
	447	(pos_loop [@tailcall]) (y::rev_prefix) xs
	448	in
	449	pos_loop [] l';
	450	chunk_size := !chunk_size / 2;
	451	done
	452
	453	let list_elems shrink l yield =
	454	(* try to shrink each element of the list *)
	455	let rec elem_loop rev_prefix suffix = match suffix with
	456	\| [] -> ()
	457	\| x::xs ->
	458	shrink x (fun x' -> yield (List.rev_append rev_prefix (x'::xs)));
	459	elem_loop (x::rev_prefix) xs
	460	in
	461	elem_loop [] l
	462
388	463	let list ?shrink l yield =
389		array ?shrink (Array.of_list l)
390		(fun a -> yield (Array.to_list a))
	464	list_spine l yield;
	465	match shrink with
	466	\| None -> ()
	467	\| Some shrink -> list_elems shrink l yield
391	468
392	469	let pair a b (x,y) yield =
393	470	a x (fun x' -> yield (x',y));

560	637	let pos_float = make_scalar ~print:string_of_float Gen.pfloat
561	638	let neg_float = make_scalar ~print:string_of_float Gen.nfloat
562	639
	640	let float_bound_inclusive bound =
	641	make_scalar ~print:string_of_float (Gen.float_bound_inclusive bound)
	642
	643	let float_bound_exclusive bound =
	644	make_scalar ~print:string_of_float (Gen.float_bound_exclusive bound)
	645
	646	let float_range low high = make_scalar ~print:string_of_float (Gen.float_range low high)
	647
563	648	let int = make_int Gen.int
564	649	let int_bound n = make_int (Gen.int_bound n)
565	650	let int_range a b = make_int (Gen.int_range a b)

587	672
588	673	let string = string_gen Gen.char
589	674	let string_of_size size = string_gen_of_size size Gen.char
590		let small_string = string_gen_of_size Gen.(0--10) Gen.char
	675	let small_string = string_gen_of_size Gen.small_nat Gen.char
591	676
592	677	let printable_string = string_gen Gen.printable
593	678	let printable_string_of_size size = string_gen_of_size size Gen.printable
594		let small_printable_string = string_gen_of_size Gen.(0--10) Gen.printable
	679	let small_printable_string = string_gen_of_size Gen.small_nat Gen.printable
595	680
596	681	let numeral_string = string_gen Gen.numeral
597	682	let numeral_string_of_size size = string_gen_of_size size Gen.numeral

1041	1126
1042	1127	type 'a failed_state = 'a counter_ex list
1043	1128
	1129	(** Result state.
	1130	changed in 0.10 (move to inline records) *)
1044	1131	type 'a state =
1045	1132	\| Success
1046		\| Failed of 'a failed_state (** Failed instances *)
1047		\| Error of 'a counter_ex * exn * string (** Error, backtrace, and instance
1048		that triggered it *)
	1133	\| Failed of {
	1134	instances: 'a failed_state; (** Failed instance(s) *)
	1135	}
	1136	\| Failed_other of {msg: string}
	1137	\| Error of {
	1138	instance: 'a counter_ex;
	1139	exn: exn;
	1140	backtrace: string;
	1141	} (** Error, backtrace, and instance that triggered it *)
	1142
1049	1143
1050	1144	(* result returned by running a test *)
1051	1145	type 'a t = {

1054	1148	mutable count_gen: int; (* number of generated cases *)
1055	1149	collect_tbl: (string, int) Hashtbl.t lazy_t;
1056	1150	stats_tbl: ('a stat * (int, int) Hashtbl.t) list;
	1151	mutable warnings: string list;
1057	1152	mutable instances: 'a list;
1058	1153	}
1059	1154

1061	1156	let fail ~msg_l ~small ~steps:shrink_steps res instance =
1062	1157	let c_ex = {instance; shrink_steps; msg_l; } in
1063	1158	match res.state with
1064		\| Success -> res.state <- Failed [ c_ex ]
1065		\| Error (x, e, bt) ->
1066		res.state <- Error (x,e,bt); (* same *)
1067		\| Failed [] -> assert false
1068		\| Failed (c_ex' :: _ as l) ->
	1159	\| Success -> res.state <- Failed {instances=[ c_ex ]}
	1160	\| Error _
	1161	\| Failed_other _ -> ()
	1162	\| Failed {instances=[]} -> assert false
	1163	\| Failed {instances=((c_ex'::_) as l)} ->
1069	1164	match small with
1070	1165	\| Some small ->
1071	1166	(* all counter-examples in [l] have same size according to [small],
1072	1167	so we just compare to the first one, and we enforce
1073	1168	the invariant *)
1074	1169	begin match Pervasives.compare (small instance) (small c_ex'.instance) with
1075		\| 0 -> res.state <- Failed (c_ex :: l) (* same size: add [c_ex] to [l] *)
1076		\| n when n<0 -> res.state <- Failed [c_ex] (* drop [l] *)
	1170	\| 0 -> res.state <- Failed {instances=c_ex :: l} (* same size: add [c_ex] to [l] *)
	1171	\| n when n<0 -> res.state <- Failed {instances=[c_ex]} (* drop [l] *)
1077	1172	\| _ -> () (* drop [c_ex], not small enough *)
1078	1173	end
1079	1174	\| _ ->
1080	1175	(* no [small] function, keep all counter-examples *)
1081	1176	res.state <-
1082		Failed (c_ex :: l)
1083
1084		let error ~msg_l ~steps res instance e bt =
1085		res.state <- Error ({instance; shrink_steps=steps; msg_l; }, e, bt)
	1177	Failed {instances=c_ex :: l}
	1178
	1179	let error ~msg_l ~steps res instance exn backtrace =
	1180	res.state <- Error {instance={instance; shrink_steps=steps; msg_l; }; exn; backtrace}
1086	1181
1087	1182	let collect r =
1088	1183	if Lazy.is_val r.collect_tbl then Some (Lazy.force r.collect_tbl) else None
1089	1184
1090	1185	let stats r = r.stats_tbl
	1186	let warnings r = r.warnings
1091	1187
1092	1188	let is_success r = match r.state with
1093	1189	\| Success -> true
1094		\| Failed _ \| Error _ -> false
	1190	\| Failed _ \| Error _ \| Failed_other _ -> false
1095	1191	end
1096	1192
1097	1193	module Test = struct

1102	1198	max_fail : int; (* max number of failures *)
1103	1199	law : 'a -> bool; (* the law to check *)
1104	1200	arb : 'a arbitrary; (* how to generate/print/shrink instances *)
	1201	if_assumptions_fail: [`Fatal \| `Warning] * float;
1105	1202	mutable name : string; (* name of the law *)
1106	1203	}
1107	1204

1121	1218	let r = ref 0 in
1122	1219	(fun () -> incr r; Printf.sprintf "anon_test_%d" !r)
1123	1220
1124		let make_cell ?(count=default_count) ?(long_factor=1) ?max_gen
	1221	let default_if_assumptions_fail = `Warning, 0.05
	1222
	1223	let make_cell ?(if_assumptions_fail=default_if_assumptions_fail)
	1224	?(count=default_count) ?(long_factor=1) ?max_gen
1125	1225	?(max_fail=1) ?small ?(name=fresh_name()) arb law
1126	1226	=
1127	1227	let max_gen = match max_gen with None -> count + 200 \| Some x->x in

1134	1234	name;
1135	1235	count;
1136	1236	long_factor;
	1237	if_assumptions_fail;
1137	1238	}
1138	1239
1139		let make ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law =
1140		Test (make_cell ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law)
	1240	let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law =
	1241	Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law)
1141	1242
1142	1243	(** {6 Running the test} *)
1143	1244

1174	1275	handler : 'a handler;
1175	1276	rand: Random.State.t;
1176	1277	mutable res: 'a TestResult.t;
1177		mutable cur_count: int; (** number of iterations to do *)
	1278	mutable cur_count: int; (** number of iterations remaining to do *)
1178	1279	mutable cur_max_gen: int; (** maximum number of generations allowed *)
1179	1280	mutable cur_max_fail: int; (** maximum number of counter-examples allowed *)
1180	1281	}

1338	1439
1339	1440	let callback_nil_ : _ callback = fun _ _ _ -> ()
1340	1441
	1442	(* check that there are sufficiently many tests which passed, to avoid
	1443	the case where they all passed by failed precondition *)
	1444	let check_if_assumptions target_count cell res : unit =
	1445	let percentage_of_count = float_of_int res.R.count /. float_of_int target_count in
	1446	let assm_flag, assm_frac = cell.if_assumptions_fail in
	1447	if R.is_success res && percentage_of_count < assm_frac then (
	1448	let msg =
	1449	format_of_string "%s: \
	1450	only %.1f%% tests (of %d) passed precondition for %S\n\n\
	1451	NOTE: it is likely that the precondition is too strong, or that \
	1452	the generator is buggy.\n%!"
	1453	in
	1454	match assm_flag with
	1455	\| `Warning ->
	1456	let msg = Printf.sprintf
	1457	msg "WARNING"
	1458	(percentage_of_count *. 100.) cell.count cell.name in
	1459	res.R.warnings <- msg :: res.R.warnings
	1460	\| `Fatal ->
	1461	(* turn it into an error *)
	1462	let msg = Printf.sprintf
	1463	msg "ERROR"
	1464	(percentage_of_count *. 100.) cell.count cell.name in
	1465	res.R.state <- R.Failed_other {msg}
	1466	)
	1467
1341	1468	(* main checking function *)
1342	1469	let check_cell ?(long=false) ?(call=callback_nil_)
1343	1470	?(step=step_nil_) ?(handler=handler_nil_)
1344	1471	?(rand=Random.State.make [\| 0 \|]) cell =
1345	1472	let factor = if long then cell.long_factor else 1 in
	1473	let target_count = factor*cell.count in
1346	1474	let state = {
1347	1475	test=cell; rand;
1348	1476	step; handler;
1349		cur_count=factor*cell.count;
	1477	cur_count=target_count;
1350	1478	cur_max_gen=factor*cell.max_gen;
1351	1479	cur_max_fail=factor*cell.max_fail;
1352	1480	res = {R.
1353	1481	state=R.Success; count=0; count_gen=0;
1354	1482	collect_tbl=lazy (Hashtbl.create 10);
1355		instances=[];
	1483	instances=[]; warnings=[];
1356	1484	stats_tbl= List.map (fun stat -> stat, Hashtbl.create 10) cell.arb.stats;
1357	1485	};
1358	1486	} in
1359	1487	let res = check_state state in
	1488	check_if_assumptions target_count cell res;
1360	1489	call cell.name cell res;
1361	1490	res
1362	1491

1453	1582	let hist_size, bucket_size =
1454	1583	let sample_width = Int64.(sub (of_int max_idx) (of_int min_idx)) in
1455	1584	if sample_width > Int64.of_int stat_max_lines
1456		then 1+stat_max_lines,
	1585	then stat_max_lines,
1457	1586	int_of_float (ceil (Int64.to_float sample_width /. float_of_int stat_max_lines))
1458		else 1+max_idx-min_idx, 1
	1587	else max_idx-min_idx, 1
1459	1588	in
	1589	let hist_size = if min_idx + bucket_size * hist_size <= max_idx then 1+hist_size else hist_size in
1460	1590	(* accumulate bucket counts *)
1461	1591	let max_val = ref 0 in (* max value after grouping by buckets *)
1462	1592	let bucket_count = Array.init hist_size (fun _ -> 0) in

1472	1602	Printf.bprintf out
1473	1603	" num: %d, avg: %.2f, stddev: %.2f, median %d, min %d, max %d\n"
1474	1604	!num !avg stddev !median min_idx max_idx;
	1605	let indwidth =
	1606	max (String.length (Printf.sprintf "%d" min_idx))
	1607	(max (String.length (Printf.sprintf "%d" max_idx))
	1608	(String.length (Printf.sprintf "%d" (min_idx + bucket_size * hist_size)))) in
	1609	let labwidth = if bucket_size=1 then indwidth else 2+2*indwidth in
1475	1610	for i = 0 to hist_size - 1 do
1476	1611	let i' = min_idx + i * bucket_size in
1477	1612	let blabel =
1478	1613	if bucket_size=1
1479		then Printf.sprintf "%d" i'
1480		else Printf.sprintf "%d..%d" i' (i'+bucket_size-1) in
	1614	then Printf.sprintf "%*d" indwidth i'
	1615	else
	1616	let bucket_bound = i'+bucket_size-1 in
	1617	Printf.sprintf "%d..%d" indwidth i' indwidth (if bucket_bound < i' then max_int else bucket_bound) in
1481	1618	let bcount = bucket_count.(i) in
1482	1619	(* NOTE: keep in sync *)
1483	1620	let bar_len = bcount * 55 / !max_val in
1484		Printf.bprintf out " %15s: %-56s %10d\n" blabel (String.make bar_len '#') bcount
	1621	Printf.bprintf out " %*s: %-56s %10d\n" labwidth blabel (String.make bar_len '#') bcount
1485	1622	done;
1486	1623	Buffer.contents out
1487	1624

1494	1631	let print_fail arb name l =
1495	1632	print_test_fail name (List.map (print_c_ex arb) l)
1496	1633
	1634	let print_fail_other name ~msg =
	1635	print_test_fail name [msg]
	1636
1497	1637	let print_error ?(st="") arb name (i,e) =
1498	1638	print_test_error name (print_c_ex arb i) e st
1499	1639
1500	1640	let check_result cell res = match res.R.state with
1501	1641	\| R.Success -> ()
1502		\| R.Error (i,e, bt) ->
1503		raise (Test_error (cell.name, print_c_ex cell.arb i, e, bt))
1504		\| R.Failed l ->
1505		let l = List.map (print_c_ex cell.arb) l in
1506		raise (Test_fail (cell.name, l))
	1642	\| R.Error {instance; exn; backtrace} ->
	1643	raise (Test_error (cell.name, print_c_ex cell.arb instance, exn, backtrace))
	1644	\| R.Failed {instances=l} ->
	1645	let l = List.map (print_c_ex cell.arb) l in
	1646	raise (Test_fail (cell.name, l))
	1647	\| R.Failed_other {msg} ->
	1648	raise (Test_fail (cell.name, [msg]))
1507	1649
1508	1650	let check_cell_exn ?long ?call ?step ?rand cell =
1509	1651	let res = check_cell ?long ?call ?step ?rand cell in

1523	1665	let res = Test.check_cell ~rand:st cell in
1524	1666	begin match res.TestResult.state with
1525	1667	\| TestResult.Success -> raise (No_example_found name)
1526		\| TestResult.Error (_, _, _) -> raise (No_example_found name)
1527		\| TestResult.Failed [] -> assert false
1528		\| TestResult.Failed (failed::_) ->
	1668	\| TestResult.Error _ -> raise (No_example_found name)
	1669	\| TestResult.Failed {instances=[]} -> assert false
	1670	\| TestResult.Failed {instances=failed::_} ->
1529	1671	(* found counter-example! *)
1530	1672	failed.TestResult.instance
	1673	\| TestResult.Failed_other {msg=_} ->
	1674	raise (No_example_found name)
	1675
1531	1676	end
1532	1677	in
1533	1678	gen

+126

-21

src/core/QCheck.mli less more

189	189	val shuffle_l : 'a list -> 'a list t
190	190	(** Creates a generator of shuffled lists. *)
191	191
192		val unit: unit t (** The unit generator. *)
193
194		val bool: bool t (** The boolean generator. *)
195
196		val float: float t (** Generates floating point numbers. *)
	192	val shuffle_w_l : (int * 'a) list -> 'a list t
	193	(** Creates a generator of weighted shuffled lists. A given list is shuffled on each
	194	generation according to the weights of its elements. An element with a larger weight
	195	is more likely to be at the front of the list than an element with a smaller weight.
	196	If we want to pick random elements from the (head of) list but need to prioritize
	197	some elements over others, this generator can be useful.
	198
	199	Example: given a weighted list [[1, "one"; 5, "five"; 10, "ten"]], the generator is
	200	more likely to generate [["ten"; "five"; "one"]] or [["five"; "ten"; "one"]] than
	201	[["one"; "ten"; "five"]] because "ten" and "five" have larger weights than "one".
	202
	203	@since 0.11
	204	*)
	205
	206	val unit : unit t (** The unit generator. *)
	207
	208	val bool : bool t (** The boolean generator. *)
	209
	210	val float : float t (** Generates floating point numbers. *)
197	211
198	212	val pfloat : float t (** Generates positive floating point numbers (0. included). *)
199	213
200	214	val nfloat : float t (** Generates negative floating point numbers. (-0. included) *)
201	215
	216	val float_bound_inclusive : float -> float t
	217	(** [float_bound_inclusive bound] returns a random floating-point number between 0 and
	218	[bound] (inclusive). If [bound] is negative, the result is negative or zero. If
	219	[bound] is 0, the result is 0.
	220	@since 0.11 *)
	221
	222	val float_bound_exclusive : float -> float t
	223	(** [float_bound_exclusive bound] returns a random floating-point number between 0 and
	224	[bound] (exclusive). If [bound] is negative, the result is negative or zero.
	225	@raise Invalid_argument if [bound] is zero.
	226	@since 0.11 *)
	227
	228	val float_range : float -> float -> float t
	229	(** [float_range low high] generates floating-point numbers within [low] and [high] (inclusive)
	230	@raise Invalid_argument if [high < low] or if the range is larger than [max_float].
	231	@since 0.11 *)
	232
	233	val (--.) : float -> float -> float t
	234	(** Synonym for [float_range]
	235	@since 0.11 *)
	236
202	237	val nat : int t (** Generates small natural numbers. *)
203	238
	239	val big_nat : int t (** Generates natural numbers, possibly large. @since 0.10 *)
	240
204	241	val neg_int : int t (** Generates non-strictly negative integers (0 included). *)
205	242
206	243	val pint : int t (** Generates non-strictly positive integers uniformly (0 included). *)
207	244
208	245	val int : int t (** Generates integers uniformly. *)
209	246
210		val small_nat : int t (** Synonym to {!nat}. @since 0.5.1 *)
	247	val small_nat : int t (** Small integers (< 100) @since 0.5.1 *)
211	248
212	249	val small_int : int t
213	250	(** Small UNSIGNED integers, for retrocompatibility.
214	251	@deprecated use {!small_nat}. *)
215	252
216	253	val small_signed_int : int t
217		(** Small SIGNED integers.
	254	(** Small SIGNED integers, based on {!small_nat}.
218	255	@since 0.5.2 *)
219	256
220	257	val int_bound : int -> int t
221	258	(** Uniform integer generator producing integers within [0... bound].
	259	For [bound < 2^{30} - 1] uses [Random.State.int] for integer generation.
222	260	@raise Invalid_argument if the argument is negative. *)
223	261
224	262	val int_range : int -> int -> int t

282	320
283	321	val string : ?gen:char t -> string t
284	322	(** Builds a string generator. String size is generated by {!nat}.
	323	Accepts an optional character generator (the default is {!char}).
	324	See also {!string_of} and {!string_readable} for versions without
	325	optional parameters. *)
	326
	327	val string_of : char t -> string t
	328	(** Builds a string generator using the given character generator.
	329	@since 0.11 *)
	330
	331	val string_readable : string t
	332	(** Builds a string generator using the {!char} character generator.
	333	@since 0.11 *)
	334
	335	val small_string : ?gen:char t -> string t
	336	(** Builds a string generator, length is {!small_nat}
285	337	Accepts an optional character generator (the default is {!char}). *)
286	338
287		val small_string : ?gen:char t -> string t
288		(** Builds a string generator. String size is in the range [0--10].
289		Accepts an optional character generator (the default is {!char}). *)
290
291	339	val small_list : 'a t -> 'a list t
292		(** Generates lists of small size (range [0 -- 10]).
	340	(** Generates lists of small size (see {!small_nat}).
293	341	@since 0.5.3 *)
	342
	343	val small_array : 'a t -> 'a array t
	344	(** Generates arrays of small size (see {!small_nat}).
	345	@since 0.10 *)
294	346
295	347	val join : 'a t t -> 'a t
296	348	(** Collapses a generator of generators to simply a generator.

306	358	to the size-bounded generator.
307	359	@since 0.5 *)
308	360
309		val fix : ('a sized -> 'a sized) -> 'a sized
310		(** Fixpoint combinator for generating recursive, size-bounded data types.
	361	val fix : (('a -> 'b t) -> ('a -> 'b t)) -> 'a -> 'b t
	362	(** Parametrized fixpoint combinator for generating recursive values.
	363
	364	The fixpoint is parametrized over an arbitrary state ('a), and the
	365	fixpoint computation may change the value of this state in the recursive
	366	calls.
	367
	368	In particular, this can be used for size-bounded generators ('a is int).
311	369	The passed size-parameter should decrease to ensure termination. *)
312	370
313	371	(** Example:

449	507	@since 0.7 *)
450	508
451	509	val list : ?shrink:'a t -> 'a list t
452		(** Try to shrink lists by removing elements one by one.
	510	(** Try to shrink lists by removing one or more elements.
453	511	@param shrink if provided, will be used to also try to reduce
454	512	the elements of the list themselves (e.g. in an [int list]
455	513	one can try to decrease the integers). *)
	514
	515	val list_spine : 'a list t
	516	(** Try to shrink lists by removing one or more elements.
	517	@since 0.10 *)
	518
	519	val list_elems : 'a t -> 'a list t
	520	(** Shrinks the elements of a list, without changing the list size.
	521	@since 0.10 *)
456	522
457	523	val array : ?shrink:'a t -> 'a array t
458	524	(** Shrink an array.

604	670
605	671	type 'a failed_state = 'a counter_ex list
606	672
	673	(** Result state.
	674	changed in 0.10 (move to inline records, add Fail_other) *)
607	675	type 'a state =
608	676	\| Success
609		\| Failed of 'a failed_state (** Failed instances *)
610		\| Error of 'a counter_ex * exn * string (** Error, backtrace, and instance
611		that triggered it *)
	677	\| Failed of {
	678	instances: 'a failed_state; (** Failed instance(s) *)
	679	}
	680	\| Failed_other of {msg: string}
	681	\| Error of {
	682	instance: 'a counter_ex;
	683	exn: exn;
	684	backtrace: string;
	685	} (** Error, backtrace, and instance that triggered it *)
612	686
613	687	(* result returned by running a test *)
614		type 'a t = {
	688	type 'a t = private {
615	689	mutable state : 'a state;
616	690	mutable count: int; (* Number of tests *)
617	691	mutable count_gen: int; (* Number of generated cases *)
618	692	collect_tbl: (string, int) Hashtbl.t lazy_t;
619	693	stats_tbl: ('a stat * (int, int) Hashtbl.t) list; (** @since 0.6 *)
	694	mutable warnings: string list;
620	695	mutable instances: 'a list;
621	696	(** List of instances used for this test, in no particular order.
622	697	@since 0.9 *)

630	705	(** Obtain statistics
631	706	@since 0.6 *)
632	707
	708	val warnings : _ t -> string list
	709	(** Obtain list of warnings
	710	@since 0.10 *)
	711
633	712	val is_success : _ t -> bool
634	713	(** Returns true iff the state if [Success]
635	714	@since 0.9 *)

649	728	@since 0.7 *)
650	729
651	730	val make_cell :
	731	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
652	732	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
653	733	?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) ->
654	734	'a cell

668	748	the field [arbitrary.small].
669	749	If there is no shrinking function but there is a [small]
670	750	function, only the smallest failures will be printed.
	751	@param if_assumptions_fail the minimum
	752	fraction of tests that must satisfy the precondition for a success
	753	to be considered valid.
	754	The fraction should be between 0. and 1.
	755	A warning will be emitted otherwise if
	756	the flag is [`Warning], the test will be a failure if the flag is [`Fatal].
	757	(since 0.10)
671	758	*)
672	759
673	760	val get_arbitrary : 'a cell -> 'a arbitrary

688	775	put tests on different types in the same list of tests. *)
689	776
690	777	val make :
	778	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
691	779	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
692	780	?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) -> t
693	781	(** [make arb prop] builds a test that checks property [prop] on instances

711	799	val print_instance : 'a arbitrary -> 'a -> string
712	800	val print_c_ex : 'a arbitrary -> 'a TestResult.counter_ex -> string
713	801	val print_fail : 'a arbitrary -> string -> 'a TestResult.counter_ex list -> string
	802	val print_fail_other : string -> msg:string -> string
714	803	val print_error : ?st:string -> 'a arbitrary -> string -> 'a TestResult.counter_ex * exn -> string
715	804	val print_test_fail : string -> string list -> string
716	805	val print_test_error : string -> string -> exn -> string -> string

848	937	val neg_float : float arbitrary
849	938	(** Negative float generator (no nan and no infinities). *)
850	939
	940	val float_bound_inclusive : float -> float arbitrary
	941	(** [float_bound_inclusive n] is uniform between [0] and [n] included. If [bound] is
	942	negative, the result is negative or zero. If [bound] is 0, the result is 0.
	943	@since 0.11 *)
	944
	945	val float_bound_exclusive : float -> float arbitrary
	946	(** [float_bound_exclusive n] is uniform between [0] included and [n] excluded.
	947	If [bound] is negative, the result is negative or zero.
	948	@raise Invalid_argument if [bound] is zero.
	949	@since 0.11 *)
	950
	951	val float_range : float -> float -> float arbitrary
	952	(** [float_range low high] is uniform between [low] included and [high] included.
	953	@raise Invalid_argument if [low > high] or if the range is larger than [max_float].
	954	@since 0.11 *)
	955
851	956	val int : int arbitrary
852	957	(** Int generator. Uniformly distributed. *)
853	958

914	1019	and distribution of characters of [char]. *)
915	1020
916	1021	val small_string : string arbitrary
917		(** Same as {!string} but with a small length (that is, [0--10]). *)
	1022	(** Same as {!string} but with a small length (ie {!Gen.small_nat} ). *)
918	1023
919	1024	val small_list : 'a arbitrary -> 'a list arbitrary
920		(** Generates lists of small size (range [0 -- 10]).
	1025	(** Generates lists of small size (see {!Gen.small_nat}).
921	1026	@since 0.5.3 *)
922	1027
923	1028	val string_of_size : int Gen.t -> string arbitrary

-0

src/dune less more

6	6	(modules QCheck_runner)
7	7	(synopsis "compatibility library for qcheck")
8	8	(libraries qcheck-core qcheck-core.runner qcheck-ounit))
	9
	10	(documentation
	11	(package qcheck)
	12	(mld_files index))

+13

-0

src/index.mld less more

	0
	1	{1 QCheck compatibility package}
	2
	3
	4	This library is there to ensure compatibility with QCheck 0.8 and earlier.
	5
	6	It has a unique module {!QCheck_runner} that merges the custom runners
	7	from [qcheck-core.runner] ({!QCheck_base_runner})
	8	and the OUnit runners from [qcheck-ounit] ({!QCheck_ounit})
	9	into a single module.
	10
	11	By depending on [qcheck-core], this library also brings {!QCheck} in scope,
	12	so it can be used transparently.

+28

-10

src/runner/QCheck_base_runner.ml less more

129	129	(* even if [not verbose], print errors *)
130	130	match result.R.state with
131	131	\| R.Success -> ()
132		\| R.Failed l ->
	132	\| R.Failed {instances=l} ->
133	133	print.fail "%s%s\n" Color.reset_line (T.print_fail arb name l);
134		\| R.Error (i,e,st) ->
135		print.err "%s%s\n" Color.reset_line (T.print_error ~st arb name (i,e));
	134	\| R.Failed_other {msg} ->
	135	print.fail "%s%s\n" Color.reset_line (T.print_fail_other name ~msg);
	136	\| R.Error {instance; exn; backtrace} ->
	137	print.err "%s%s\n" Color.reset_line
	138	(T.print_error ~st:backtrace arb name (instance,exn));
136	139	)
137	140
138	141	let print_std = { info = Printf.printf; fail = Printf.printf; err = Printf.printf }

268	271	(Color.pp_str_c ~colors `Blue) "Collect"
269	272	(String.make 68 '+') (QCheck.Test.get_name cell) (QCheck.Test.print_collect tbl)
270	273	end;
	274	List.iter (fun msg ->
	275	Printf.fprintf out
	276	"\n!!! %a %s\n\nWarning for test %s:\n\n%s%!"
	277	(Color.pp_str_c ~colors `Yellow) "Warning" (String.make 68 '!')
	278	(QCheck.Test.get_name cell) msg)
	279	(QCheck.TestResult.warnings r);
271	280	List.iter
272	281	(fun st ->
273	282	Printf.fprintf out

283	292	(QCheck.Test.get_name cell) c_ex.QCheck.TestResult.shrink_steps
284	293	(print_inst (QCheck.Test.get_arbitrary cell) c_ex.QCheck.TestResult.instance);
285	294	print_messages ~colors out cell c_ex.QCheck.TestResult.msg_l
	295
	296	let print_fail_other ~colors out cell msg =
	297	Printf.fprintf out "\n--- %a %s\n\n" (Color.pp_str_c ~colors `Red) "Failure" (String.make 68 '-');
	298	Printf.fprintf out "Test %s failed:\n\n%s\n%!" (QCheck.Test.get_name cell) msg
286	299
287	300	let print_error ~colors out cell c_ex exn bt =
288	301	Printf.fprintf out "\n=== %a %s\n\n" (Color.pp_str_c ~colors `Red) "Error" (String.make 70 '=');

325	338	Res (cell, r)
326	339	in
327	340	let res = List.map aux_map l in
328		let aux_fold (total, fail, error) (Res (cell, r)) =
	341	let aux_fold (total, fail, error, warns) (Res (cell, r)) =
	342	let warns = warns + List.length r.R.warnings in
329	343	let acc = match r.R.state with
330	344	\| R.Success ->
331	345	print_success ~colors out cell r;
332		(total + 1, fail, error)
333		\| R.Failed l ->
	346	(total + 1, fail, error, warns)
	347	\| R.Failed {instances=l} ->
334	348	List.iter (print_fail ~colors out cell) l;
335		(total + 1, fail + 1, error)
336		\| R.Error (c_ex, exn, bt) ->
	349	(total + 1, fail + 1, error, warns)
	350	\| R.Failed_other {msg} ->
	351	print_fail_other ~colors out cell msg;
	352	(total + 1, fail + 1, error, warns)
	353	\| R.Error {instance=c_ex; exn; backtrace=bt} ->
337	354	print_error ~colors out cell c_ex exn bt;
338		(total + 1, fail, error + 1)
	355	(total + 1, fail, error + 1, warns)
339	356	in
340	357	acc
341	358	in
342		let total, fail, error = List.fold_left aux_fold (0, 0, 0) res in
	359	let total, fail, error, warns = List.fold_left aux_fold (0, 0, 0,0) res in
343	360	Printf.fprintf out "%s\n" (String.make 80 '=');
	361	if warns > 0 then Printf.fprintf out "%d warning(s)\n" warns;
344	362	if fail = 0 && error = 0 then (
345	363	Printf.fprintf out "%a (ran %d tests)\n%!"
346	364	(pp_color `Green) "success" total;