Commit upstream/0.18.1+git20220309.1.e92837e - ocaml-qcheck

Import upstream version 0.18.1+git20220309.1.e92837e Debian Janitor 2 years ago

40 changed file(s) with 3969 addition(s) and 191 deletion(s). Raw diff Collapse all Expand all

+25

-0

CHANGELOG.md less more

0	0	# Changes
	1
	2	## 0.19
	3
	4	- add optional `debug_shrink` parameters in alcotest interface and
	5	expose default `debug_shrinking_choices` in test runners
	6
	7	- add missing `?handler` parameter to `Test.check_cell_exn`
	8
	9	- remove `--no-buffer` option on `dune runtest` to avoid garbling the
	10	test output
	11
	12	- add an option `retries` parameter `Test.make` et al. for checking a
	13	property repeatedly while shrinking.
	14	This can be useful when testing non-deterministic code.
	15	[#212](https://github.com/c-cube/qcheck/pull/212)
	16
	17	- add tup2 to tup9 for generators
	18
	19	- documentation updates:
	20	- clarify upper bound inclusion in `Gen.int_bound` and `Gen.int_range`
	21	- clarify `printable_char` and `Gen.printable` distributions
	22	- add missing `string_gen_of_size` and `small_printable_string` documentation
	23	- document `QCheck_alcotest.to_alcotest`
	24	- fix documented size distribution for `arbitrary` generators
	25	`string_gen`, `string`, `printable_string`, `numeral_string`, `list`, and `array`
1	26
2	27	## 0.18.1
3	28

-1

Makefile less more

4	4	@dune build @install
5	5
6	6	test:
7		@dune runtest --no-buffer --force
	7	@dune runtest --force
8	8
9	9	clean:
10	10	@dune clean

+13

-3

example/alcotest/QCheck_alcotest_test.ml less more

47	47	QCheck.(make gen_tree)
48	48	(fun tree -> rev_tree (rev_tree tree) = tree)
49	49
	50	let debug_shrink =
	51	QCheck.Test.make ~count:10
	52	~name:"debug_shrink"
	53	(* we use a very constrained test to have a smaller shrinking tree *)
	54	QCheck.(pair (1 -- 3) (1 -- 3))
	55	(fun (a, b) -> a = b);;
	56
50	57	let () =
51	58	Printexc.record_backtrace true;
52	59	let module A = Alcotest in

54	61	List.map QCheck_alcotest.to_alcotest
55	62	[ passing; failing; error; simple_qcheck; passing_tree_rev ]
56	63	in
57		A.run "my test" [
58		"suite", suite
59		]
	64	A.run ~show_errors:true "my test" [
	65	"suite", suite;
	66	"shrinking", [
	67	QCheck_alcotest.to_alcotest ~verbose:true ~debug_shrink:(Some stdout) debug_shrink
	68	];
	69	];

+53

-7

example/alcotest/output.txt.expected less more

0	0	qcheck random seed: 1234
1	1	Testing `my test'.
2		[OK] suite 0 list_rev_is_involutive.
3		> [FAIL] suite 1 fail_sort_id.
4		[FAIL] suite 2 error_raise_exn.
5		[FAIL] suite 3 fail_check_err_message.
6		[OK] suite 4 tree_rev_is_involutive.
	2	[OK] suite 0 list_rev_is_involutive.
	3	[FAIL] suite 1 fail_sort_id.
	4	[FAIL] suite 2 error_raise_exn.
	5	[FAIL] suite 3 fail_check_err_message.
	6	[OK] suite 4 tree_rev_is_involutive.
	7	[FAIL] shrinking 0 debug_shrink.
7	8	┌──────────────────────────────────────────────────────────────────────────────┐
8		│ [FAIL] suite 1 fail_sort_id. │
	9	│ [FAIL] suite 1 fail_sort_id. │
9	10	└──────────────────────────────────────────────────────────────────────────────┘
10	11	test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 20 shrink steps)
11	12	[exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 20 shrink steps)
12	13	──────────────────────────────────────────────────────────────────────────────
13		3 failures! 5 tests run.
	14	┌──────────────────────────────────────────────────────────────────────────────┐
	15	│ [FAIL] suite 2 error_raise_exn. │
	16	└──────────────────────────────────────────────────────────────────────────────┘
	17	test `error_raise_exn`
	18	raised exception `Error`
	19	on `0 (after 63 shrink steps)`
	20	[exception] test `error_raise_exn`
	21	raised exception `Error`
	22	on `0 (after 63 shrink steps)`
	23	──────────────────────────────────────────────────────────────────────────────
	24	┌──────────────────────────────────────────────────────────────────────────────┐
	25	│ [FAIL] suite 3 fail_check_err_message. │
	26	└──────────────────────────────────────────────────────────────────────────────┘
	27	test `fail_check_err_message` failed on ≥ 1 cases:
	28	0 (after 7 shrink steps)
	29	this
	30	will
	31	always
	32	fail
	33	[exception] test `fail_check_err_message` failed on ≥ 1 cases:
	34	0 (after 7 shrink steps)
	35	this
	36	will
	37	always
	38	fail
	39	──────────────────────────────────────────────────────────────────────────────
	40	┌──────────────────────────────────────────────────────────────────────────────┐
	41	│ [FAIL] shrinking 0 debug_shrink. │
	42	└──────────────────────────────────────────────────────────────────────────────┘
	43	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	44	Test debug_shrink successfully shrunk counter example (step 0) to:
	45	(3, 1)
	46	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	47	Test debug_shrink successfully shrunk counter example (step 1) to:
	48	(2, 1)
	49	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	50	Test debug_shrink successfully shrunk counter example (step 2) to:
	51	(2, 0)
	52	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	53	Test debug_shrink successfully shrunk counter example (step 3) to:
	54	(1, 0)
	55	law debug_shrink: 2 relevant cases (2 total)
	56	test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps)
	57	[exception] test `debug_shrink` failed on ≥ 1 cases: (1, 0) (after 3 shrink steps)
	58	──────────────────────────────────────────────────────────────────────────────
	59	4 failures! 6 tests run.

-0

example/alcotest/run_alcotest.sh less more

11	11	\| grep -v 'Raised at ' \
12	12	\| grep -v 'Called from ' \
13	13	\| sed 's/! in .*s\./!/' \
	14	\| sed 's/`.*.Error`/`Error`/g' \
14	15	\| sed 's/[ \t]*$//g' \
15	16	\| tr -s "\n"
16	17	exit $CODE

+28

-0

ppx_deriving_qcheck.opam less more

	0	opam-version: "2.0"
	1	name: "ppx_deriving_qcheck"
	2	version: "0.2.0"
	3	license: "BSD-2-Clause"
	4	synopsis: "PPX Deriver for QCheck"
	5
	6	maintainer: "valentin.chb@gmail.com"
	7	author: [ "the qcheck contributors" ]
	8
	9	depends: [
	10	"dune" {>= "2.8.0"}
	11	"ocaml" {>= "4.08.0"}
	12	"qcheck" {>= "0.17"}
	13	"ppxlib" {>= "0.22.0"}
	14	"ppx_deriving" {>= "5.2.1"}
	15	"odoc" {with-doc}
	16	"alcotest" {with-test & >= "1.4.0" }
	17	]
	18
	19	build: [
	20	["dune" "build" "-p" name "-j" jobs]
	21	["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc}
	22	["dune" "runtest" "-p" name "-j" jobs] {with-test}
	23	]
	24
	25	homepage: "https://github.com/c-cube/qcheck/"
	26	bug-reports: "https://github.com/c-cube/qcheck/-/issues"
	27	dev-repo: "git+https://github.com/vch9/ppx_deriving_qcheck.git"

-1

qcheck-alcotest.opam less more

4	4	license: "BSD-2-Clause"
5	5	synopsis: "Alcotest backend for qcheck"
6	6	doc: ["http://c-cube.github.io/qcheck/"]
7		version: "0.18.1"
	7	version: "0.18"
8	8	tags: [
9	9	"test"
10	10	"quickcheck"

-1

qcheck-core.opam less more

4	4	license: "BSD-2-Clause"
5	5	synopsis: "Core qcheck library"
6	6	doc: ["http://c-cube.github.io/qcheck/"]
7		version: "0.18.1"
	7	version: "0.18"
8	8	tags: [
9	9	"test"
10	10	"property"

-1

qcheck-ounit.opam less more

4	4	homepage: "https://github.com/c-cube/qcheck/"
5	5	doc: ["http://c-cube.github.io/qcheck/"]
6	6	synopsis: "OUnit backend for qcheck"
7		version: "0.18.1"
	7	version: "0.18"
8	8	tags: [
9	9	"qcheck"
10	10	"quickcheck"

-1

qcheck.opam less more

4	4	homepage: "https://github.com/c-cube/qcheck/"
5	5	license: "BSD-2-Clause"
6	6	doc: ["http://c-cube.github.io/qcheck/"]
7		version: "0.18.1"
	7	version: "0.18"
8	8	tags: [
9	9	"test"
10	10	"property"

+20

-4

src/alcotest/QCheck_alcotest.ml less more

32	32	)
33	33
34	34	let to_alcotest
35		?(verbose=Lazy.force verbose_) ?(long=Lazy.force long_) ?(rand=default_rand())
	35	?(colors=false) ?(verbose=Lazy.force verbose_) ?(long=Lazy.force long_)
	36	?(debug_shrink = None) ?debug_shrink_list ?(rand=default_rand())
36	37	(t:T.t) =
37	38	let T.Test cell = t in
	39	let handler name cell r =
	40	match r, debug_shrink with
	41	\| QCheck2.Test.Shrunk (step, x), Some out ->
	42	let go = match debug_shrink_list with
	43	\| None -> true
	44	\| Some test_list -> List.mem name test_list in
	45	if not go then ()
	46	else
	47	QCheck_base_runner.debug_shrinking_choices
	48	~colors ~out ~name cell ~step x
	49	\| _ ->
	50	()
	51	in
38	52	let print = Raw.print_std in
39	53	let run() =
40		T.check_cell_exn cell
41		~long ~rand ~call:(Raw.callback ~colors:false ~verbose ~print_res:true ~print)
	54	let call = Raw.callback ~colors ~verbose ~print_res:true ~print in
	55	T.check_cell_exn
	56	~long ~call ~handler ~rand
	57	cell
42	58	in
43	59	let name = T.get_name cell in
44		name, `Slow, run
	60	((name, `Slow, run) : unit Alcotest.test_case)

+12

-4

src/alcotest/QCheck_alcotest.mli less more

11	11	*)
12	12
13	13	val to_alcotest :
14		?verbose:bool -> ?long:bool -> ?rand:Random.State.t ->
	14	?colors:bool -> ?verbose:bool -> ?long:bool ->
	15	?debug_shrink:(out_channel option) ->
	16	?debug_shrink_list:(string list) ->
	17	?rand:Random.State.t ->
15	18	QCheck2.Test.t -> unit Alcotest.test_case
16		(** Convert a qcheck test into an alcotest test
17		@param verbose used to print information on stdout (default: [verbose()])
18		@param rand the random generator to use (default: [random_state ()])
	19	(** Convert a qcheck test into an alcotest test.
	20
	21	In addition to the environment variables mentioned above, you can control
	22	the behavior of QCheck tests using optional parameters that behave in the
	23	same way as the parameters of {!QCheck_base_runner.run_tests}.
	24
19	25	@since 0.9
	26	@since 0.9 parameters [verbose], [long], [rand]
	27	@since NEXT_VERSION parameters [colors], [debug_shrink], [debug_shrink_list]
20	28	*)

+356

-5

src/core/QCheck.ml less more

39	39
40	40	let _opt_map_4 ~f a b c d = match a, b, c, d with
41	41	\| Some x, Some y, Some z, Some w -> Some (f x y z w)
	42	\| _ -> None
	43
	44	let _opt_map_5 ~f a b c d e = match a, b, c, d, e with
	45	\| Some x, Some y, Some z, Some u, Some v -> Some (f x y z u v)
	46	\| _ -> None
	47
	48	let _opt_map_6 ~f a b c d e g = match a, b, c, d, e, g with
	49	\| Some a, Some b, Some c, Some d, Some e, Some g -> Some (f a b c d e g)
	50	\| _ -> None
	51
	52	let _opt_map_7 ~f a b c d e g h = match a, b, c, d, e, g, h with
	53	\| Some a, Some b, Some c, Some d, Some e, Some g, Some h -> Some (f a b c d e g h)
	54	\| _ -> None
	55
	56	let _opt_map_8 ~f a b c d e g h i = match a, b, c, d, e, g, h, i with
	57	\| Some a, Some b, Some c, Some d, Some e, Some g, Some h, Some i ->
	58	Some (f a b c d e g h i)
	59	\| _ -> None
	60
	61	let _opt_map_9 ~f a b c d e g h i j = match a, b, c, d, e, g, h, i, j with
	62	\| Some a, Some b, Some c, Some d, Some e, Some g, Some h, Some i, Some j ->
	63	Some (f a b c d e g h i j)
42	64	\| _ -> None
43	65
44	66	let _opt_sum a b = match a, b with

282	304
283	305	let char st = char_of_int (RS.int st 256)
284	306
	307	let tup2 = pair
	308
	309	let tup3 = triple
	310
	311	let tup4 = quad
	312
	313	let tup5 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) : ('a * 'b * 'c * 'd * 'e) t =
	314	(fun a b c d e -> (a, b, c, d, e)) <$> g1 <> g2 <> g3 <> g4 <> g5
	315
	316	let tup6 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) : ('a * 'b * 'c * 'd * 'e * 'f) t =
	317	(fun a b c d e f -> (a, b, c, d, e, f)) <$> g1 <> g2 <> g3 <> g4 <> g5 <*> g6
	318
	319	let tup7 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g) t =
	320	(fun a b c d e f g -> (a, b, c, d, e, f, g)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7
	321
	322	let tup8 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) (g8 : 'h t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t =
	323	(fun a b c d e f g h -> (a, b, c, d, e, f, g, h)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7 <*> g8
	324
	325	let tup9 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) (g8 : 'h t) (g9 : 'i t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t =
	326	(fun a b c d e f g h i -> (a, b, c, d, e, f, g, h, i)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7 <> g8 <> g9
	327
285	328	let printable_chars =
286	329	let l = 126-32+1 in
287	330	let s = Bytes.create l in

402	445	let triple a b c (x,y,z) = Printf.sprintf "(%s, %s, %s)" (a x) (b y) (c z)
403	446	let quad a b c d (x,y,z,w) =
404	447	Printf.sprintf "(%s, %s, %s, %s)" (a x) (b y) (c z) (d w)
	448
	449	let default = fun _ -> "<no printer>"
	450
	451	let tup2 p_a p_b (a, b) =
	452	Printf.sprintf "(%s, %s)" (p_a a) (p_b b)
	453
	454	let tup2_opt p_a p_b (a, b) =
	455	let p_a = Option.value ~default p_a in
	456	let p_b = Option.value ~default p_b in
	457	tup2 p_a p_b (a, b)
	458
	459	let tup3 p_a p_b (p_c) (a, b, c) =
	460	Printf.sprintf "(%s, %s, %s)" (p_a a) (p_b b) (p_c c)
	461
	462	let tup3_opt p_a p_b p_c (a, b, c) =
	463	let p_a = Option.value ~default p_a in
	464	let p_b = Option.value ~default p_b in
	465	let p_c = Option.value ~default p_c in
	466	tup3 p_a p_b p_c (a, b, c)
	467
	468	let tup4 p_a p_b p_c p_d (a, b, c, d) =
	469	Printf.sprintf "(%s, %s, %s, %s)"
	470	(p_a a) (p_b b)
	471	(p_c c) (p_d d)
	472
	473	let tup4_opt p_a p_b p_c p_d (a, b, c, d) =
	474	let p_a = Option.value ~default p_a in
	475	let p_b = Option.value ~default p_b in
	476	let p_c = Option.value ~default p_c in
	477	let p_d = Option.value ~default p_d in
	478	tup4 p_a p_b p_c p_d (a, b, c, d)
	479
	480	let tup5 p_a p_b p_c p_d p_e (a, b, c, d, e) =
	481	Printf.sprintf "(%s, %s, %s, %s, %s)"
	482	(p_a a) (p_b b)
	483	(p_c c) (p_d d)
	484	(p_e e)
	485
	486	let tup5_opt p_a p_b p_c p_d p_e (a, b, c, d, e) =
	487	let p_a = Option.value ~default p_a in
	488	let p_b = Option.value ~default p_b in
	489	let p_c = Option.value ~default p_c in
	490	let p_d = Option.value ~default p_d in
	491	let p_e = Option.value ~default p_e in
	492	tup5 p_a p_b p_c p_d p_e (a, b, c, d, e)
	493
	494	let tup6 p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f) =
	495	Printf.sprintf "(%s, %s, %s, %s, %s, %s)"
	496	(p_a a) (p_b b)
	497	(p_c c) (p_d d)
	498	(p_e e) (p_f f)
	499
	500	let tup6_opt p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f) =
	501	let p_a = Option.value ~default p_a in
	502	let p_b = Option.value ~default p_b in
	503	let p_c = Option.value ~default p_c in
	504	let p_d = Option.value ~default p_d in
	505	let p_e = Option.value ~default p_e in
	506	let p_f = Option.value ~default p_f in
	507	tup6 p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f)
	508
	509	let tup7 p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g) =
	510	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s)"
	511	(p_a a) (p_b b)
	512	(p_c c) (p_d d)
	513	(p_e e) (p_f f)
	514	(p_g g)
	515
	516	let tup7_opt p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g) =
	517	let p_a = Option.value ~default p_a in
	518	let p_b = Option.value ~default p_b in
	519	let p_c = Option.value ~default p_c in
	520	let p_d = Option.value ~default p_d in
	521	let p_e = Option.value ~default p_e in
	522	let p_f = Option.value ~default p_f in
	523	let p_g = Option.value ~default p_g in
	524	tup7 p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g)
	525
	526	let tup8 p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h) =
	527	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s, %s)"
	528	(p_a a) (p_b b)
	529	(p_c c) (p_d d)
	530	(p_e e) (p_f f)
	531	(p_g g) (p_h h)
	532
	533	let tup8_opt p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h) =
	534	let p_a = Option.value ~default p_a in
	535	let p_b = Option.value ~default p_b in
	536	let p_c = Option.value ~default p_c in
	537	let p_d = Option.value ~default p_d in
	538	let p_e = Option.value ~default p_e in
	539	let p_f = Option.value ~default p_f in
	540	let p_g = Option.value ~default p_g in
	541	let p_h = Option.value ~default p_h in
	542	tup8 p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h)
	543
	544	let tup9 p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i) =
	545	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s, %s, %s)"
	546	(p_a a) (p_b b)
	547	(p_c c) (p_d d)
	548	(p_e e) (p_f f)
	549	(p_g g) (p_h h)
	550	(p_i i)
	551
	552	let tup9_opt p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i) =
	553	let p_a = Option.value ~default p_a in
	554	let p_b = Option.value ~default p_b in
	555	let p_c = Option.value ~default p_c in
	556	let p_d = Option.value ~default p_d in
	557	let p_e = Option.value ~default p_e in
	558	let p_f = Option.value ~default p_f in
	559	let p_g = Option.value ~default p_g in
	560	let p_h = Option.value ~default p_h in
	561	let p_i = Option.value ~default p_i in
	562	tup9 p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i)
405	563
406	564	let list pp l =
407	565	let b = Buffer.create 25 in

612	770	b y (fun y' -> yield (x,y',z,w));
613	771	c z (fun z' -> yield (x,y,z',w));
614	772	d w (fun w' -> yield (x,y,z,w'))
	773
	774	let default = nil
	775
	776	let tup2 = pair
	777
	778	let tup2_opt a b =
	779	let a = Option.value ~default a in
	780	let b = Option.value ~default b in
	781	tup2 a b
	782
	783	let tup3 = triple
	784
	785	let tup3_opt a b c =
	786	let a = Option.value ~default a in
	787	let b = Option.value ~default b in
	788	let c = Option.value ~default c in
	789	tup3 a b c
	790
	791	let tup4 = quad
	792
	793	let tup4_opt a b c d =
	794	let a = Option.value ~default a in
	795	let b = Option.value ~default b in
	796	let c = Option.value ~default c in
	797	let d = Option.value ~default d in
	798	tup4 a b c d
	799
	800	let tup5 a b c d e (a', b', c', d', e') yield =
	801	a a' (fun x -> yield (x,b',c',d',e'));
	802	b b' (fun x -> yield (a',x,c',d',e'));
	803	c c' (fun x -> yield (a',b',x,d',e'));
	804	d d' (fun x -> yield (a',b',c',x,e'));
	805	e e' (fun x -> yield (a',b',c',d',x))
	806
	807	let tup5_opt a b c d e =
	808	let a = Option.value ~default a in
	809	let b = Option.value ~default b in
	810	let c = Option.value ~default c in
	811	let d = Option.value ~default d in
	812	let e = Option.value ~default e in
	813	tup5 a b c d e
	814
	815	let tup6 a b c d e f (a', b', c', d', e', f') yield =
	816	a a' (fun x -> yield (x,b',c',d',e',f'));
	817	b b' (fun x -> yield (a',x,c',d',e',f'));
	818	c c' (fun x -> yield (a',b',x,d',e',f'));
	819	d d' (fun x -> yield (a',b',c',x,e',f'));
	820	e e' (fun x -> yield (a',b',c',d',x,f'));
	821	f f' (fun x -> yield (a',b',c',d',e',x))
	822
	823	let tup6_opt a b c d e f =
	824	let a = Option.value ~default a in
	825	let b = Option.value ~default b in
	826	let c = Option.value ~default c in
	827	let d = Option.value ~default d in
	828	let e = Option.value ~default e in
	829	let f = Option.value ~default f in
	830	tup6 a b c d e f
	831
	832	let tup7 a b c d e f g (a', b', c', d', e', f', g') yield =
	833	a a' (fun x -> yield (x,b',c',d',e',f',g'));
	834	b b' (fun x -> yield (a',x,c',d',e',f',g'));
	835	c c' (fun x -> yield (a',b',x,d',e',f',g'));
	836	d d' (fun x -> yield (a',b',c',x,e',f',g'));
	837	e e' (fun x -> yield (a',b',c',d',x,f',g'));
	838	f f' (fun x -> yield (a',b',c',d',e',x,g'));
	839	g g' (fun x -> yield (a',b',c',d',e',f',x))
	840
	841	let tup7_opt a b c d e f g =
	842	let a = Option.value ~default a in
	843	let b = Option.value ~default b in
	844	let c = Option.value ~default c in
	845	let d = Option.value ~default d in
	846	let e = Option.value ~default e in
	847	let f = Option.value ~default f in
	848	let g = Option.value ~default g in
	849	tup7 a b c d e f g
	850
	851	let tup8 a b c d e f g h (a', b', c', d', e', f', g', h') yield =
	852	a a' (fun x -> yield (x,b',c',d',e',f',g',h'));
	853	b b' (fun x -> yield (a',x,c',d',e',f',g',h'));
	854	c c' (fun x -> yield (a',b',x,d',e',f',g',h'));
	855	d d' (fun x -> yield (a',b',c',x,e',f',g',h'));
	856	e e' (fun x -> yield (a',b',c',d',x,f',g',h'));
	857	f f' (fun x -> yield (a',b',c',d',e',x,g',h'));
	858	g g' (fun x -> yield (a',b',c',d',e',f',x,h'));
	859	h h' (fun x -> yield (a',b',c',d',e',f',g',x))
	860
	861	let tup8_opt a b c d e f g h =
	862	let a = Option.value ~default a in
	863	let b = Option.value ~default b in
	864	let c = Option.value ~default c in
	865	let d = Option.value ~default d in
	866	let e = Option.value ~default e in
	867	let f = Option.value ~default f in
	868	let g = Option.value ~default g in
	869	let h = Option.value ~default h in
	870	tup8 a b c d e f g h
	871
	872	let tup9 a b c d e f g h i (a', b', c', d', e', f', g', h', i') yield =
	873	a a' (fun x -> yield (x,b',c',d',e',f',g',h',i'));
	874	b b' (fun x -> yield (a',x,c',d',e',f',g',h',i'));
	875	c c' (fun x -> yield (a',b',x,d',e',f',g',h',i'));
	876	d d' (fun x -> yield (a',b',c',x,e',f',g',h',i'));
	877	e e' (fun x -> yield (a',b',c',d',x,f',g',h',i'));
	878	f f' (fun x -> yield (a',b',c',d',e',x,g',h',i'));
	879	g g' (fun x -> yield (a',b',c',d',e',f',x,h',i'));
	880	h h' (fun x -> yield (a',b',c',d',e',f',g',x,i'));
	881	i i' (fun x -> yield (a',b',c',d',e',f',g',h',x))
	882
	883	let tup9_opt a b c d e f g h i =
	884	let a = Option.value ~default a in
	885	let b = Option.value ~default b in
	886	let c = Option.value ~default c in
	887	let d = Option.value ~default d in
	888	let e = Option.value ~default e in
	889	let f = Option.value ~default f in
	890	let g = Option.value ~default g in
	891	let h = Option.value ~default h in
	892	let i = Option.value ~default i in
	893	tup9 a b c d e f g h i
615	894	end
616	895
617	896	(** {2 Observe Values} *)

874	1153	(_opt_or c.shrink Shrink.nil)
875	1154	(_opt_or d.shrink Shrink.nil))
876	1155	(Gen.quad a.gen b.gen c.gen d.gen)
	1156
	1157	let tup2 a b=
	1158	make
	1159	?small:(_opt_map_2 ~f:(fun a b (a', b') -> a a'+b b') a.small b.small)
	1160	~print:(Print.tup2_opt a.print b.print)
	1161	~shrink:(Shrink.pair (_opt_or a.shrink Shrink.nil) (_opt_or b.shrink Shrink.nil))
	1162	(Gen.tup2 a.gen b.gen)
	1163
	1164	let tup3 a b c =
	1165	make
	1166	?small:(_opt_map_3 ~f:(fun a b c (a', b', c') ->
	1167	a a'+b b'+c c') a.small b.small c.small)
	1168	~print:(Print.tup3_opt a.print b.print c.print)
	1169	~shrink:(Shrink.tup3_opt a.shrink b.shrink c.shrink)
	1170	(Gen.tup3 a.gen b.gen c.gen)
	1171
	1172	let tup4 a b c d =
	1173	make
	1174	?small:(_opt_map_4 ~f:(fun a b c d (a', b', c', d') ->
	1175	a a'+b b'+c c'+d d') a.small b.small c.small d.small)
	1176	~print:(Print.tup4_opt a.print b.print c.print d.print)
	1177	~shrink:(Shrink.tup4_opt a.shrink b.shrink c.shrink d.shrink)
	1178	(Gen.tup4 a.gen b.gen c.gen d.gen)
	1179
	1180	let tup5 a b c d e =
	1181	make
	1182	?small:(_opt_map_5 ~f:(fun a b c d e (a', b', c', d', e') ->
	1183	a a'+b b'+c c'+d d'+e e') a.small b.small c.small d.small e.small)
	1184	~print:(Print.tup5_opt a.print b.print c.print d.print e.print)
	1185	~shrink:(Shrink.tup5_opt a.shrink b.shrink c.shrink d.shrink e.shrink)
	1186	(Gen.tup5 a.gen b.gen c.gen d.gen e.gen)
	1187
	1188	let tup6 a b c d e f =
	1189	make
	1190	?small:(_opt_map_6 ~f:(fun a b c d e f (a', b', c', d', e', f') ->
	1191	a a'+b b'+c c'+d d'+e e'+f f') a.small b.small c.small d.small e.small f.small)
	1192	~print:(Print.tup6_opt a.print b.print c.print d.print e.print f.print)
	1193	~shrink:(Shrink.tup6_opt a.shrink b.shrink c.shrink d.shrink e.shrink f.shrink)
	1194	(Gen.tup6 a.gen b.gen c.gen d.gen e.gen f.gen)
	1195
	1196	let tup7 a b c d e f g =
	1197	make
	1198	?small:(_opt_map_7 ~f:(fun a b c d e f g (a', b', c', d', e', f', g') ->
	1199	a a'+b b'+c c'+d d'+e e'+f f'+g g')
	1200	a.small b.small c.small d.small e.small f.small g.small)
	1201	~print:(Print.tup7_opt
	1202	a.print b.print c.print d.print e.print f.print g.print)
	1203	~shrink:(Shrink.tup7_opt
	1204	a.shrink b.shrink c.shrink d.shrink e.shrink f.shrink g.shrink)
	1205	(Gen.tup7 a.gen b.gen c.gen d.gen e.gen f.gen g.gen)
	1206
	1207	let tup8 a b c d e f g h =
	1208	make
	1209	?small:(_opt_map_8 ~f:(fun a b c d e f g h (a', b', c', d', e', f', g', h') ->
	1210	a a'+b b'+c c'+d d'+e e'+f f'+g g'+h h')
	1211	a.small b.small c.small d.small e.small f.small g.small h.small)
	1212	~print:(Print.tup8_opt
	1213	a.print b.print c.print d.print e.print f.print g.print h.print)
	1214	~shrink:(Shrink.tup8_opt
	1215	a.shrink b.shrink c.shrink d.shrink e.shrink f.shrink g.shrink h.shrink)
	1216	(Gen.tup8 a.gen b.gen c.gen d.gen e.gen f.gen g.gen h.gen)
	1217
	1218	let tup9 a b c d e f g h i =
	1219	make
	1220	?small:(_opt_map_9 ~f:(fun a b c d e f g h i (a', b', c', d', e', f', g', h', i') ->
	1221	a a'+b b'+c c'+d d'+e e'+f f'+g g'+h h'+i i')
	1222	a.small b.small c.small d.small e.small f.small g.small h.small i.small)
	1223	~print:(Print.tup9_opt
	1224	a.print b.print c.print d.print e.print f.print g.print h.print i.print)
	1225	~shrink:(Shrink.tup9_opt
	1226	a.shrink b.shrink c.shrink d.shrink e.shrink f.shrink g.shrink h.shrink i.shrink)
	1227	(Gen.tup9 a.gen b.gen c.gen d.gen e.gen f.gen g.gen h.gen i.gen)
877	1228
878	1229	let option ?ratio a =
879	1230	let g = Gen.opt ?ratio a.gen

1328	1679
1329	1680	let make_cell ?if_assumptions_fail
1330	1681	?count ?long_factor ?max_gen
1331		?max_fail ?small:_removed_in_qcheck_2 ?name arb law
	1682	?max_fail ?small:_removed_in_qcheck_2 ?retries ?name arb law
1332	1683	=
1333	1684	let {gen; shrink; print; collect; stats; _} = arb in
1334		QCheck2.Test.make_cell_from_QCheck1 ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?name ~gen ?shrink ?print ?collect ~stats law
1335
1336		let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law =
1337		QCheck2.Test.Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?name arb law)
	1685	QCheck2.Test.make_cell_from_QCheck1 ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ~gen ?shrink ?print ?collect ~stats law
	1686
	1687	let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name arb law =
	1688	QCheck2.Test.Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?small ?retries ?name arb law)
1338	1689
1339	1690	let fail_report = QCheck2.Test.fail_report
1340	1691

+204

-17

src/core/QCheck.mli less more

292	292	@since 0.5.2 *)
293	293
294	294	val int_bound : int -> int t
295		(** Uniform integer generator producing integers within [0... bound].
	295	(** Uniform integer generator producing integers between [0] and [bound]
	296	(inclusive).
296	297	For [bound < 2^{30} - 1] uses [Random.State.int] for integer generation.
297	298	@raise Invalid_argument if the argument is negative. *)
298	299
299	300	val int_range : int -> int -> int t
300		(** Uniform integer generator producing integers within [low,high].
	301	(** Uniform integer generator producing integers within [low,high] (inclusive).
301	302	@raise Invalid_argument if [low > high]. *)
302	303
303	304	val graft_corners : 'a t -> 'a list -> unit -> 'a t

352	353	(** Generates quadruples.
353	354	@since 0.5.1 *)
354	355
	356	(** {3 Tuple of generators} *)
	357
	358	(** {4 Shrinks on [gen1], then [gen2], then ... } *)
	359
	360	val tup2 : 'a t -> 'b t -> ('a * 'b) t
	361
	362	val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
	363
	364	val tup4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
	365
	366	val tup5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
	367
	368	val tup6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t ->
	369	('a * 'b * 'c * 'd * 'e * 'f) t
	370
	371	val tup7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t ->
	372	('a * 'b * 'c * 'd * 'e * 'f * 'g) t
	373
	374	val tup8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t ->
	375	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
	376
	377	val tup9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t ->
	378	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
	379
355	380	val char : char t
356	381	(** Generates characters upto character code 255. *)
357	382
358		val printable : char t (** Generates printable characters. *)
	383	val printable : char t (** Generates printable ascii characters in the range 32 to 127 *)
359	384
360	385	val numeral : char t (** Generates numeral characters. *)
361	386

566	591	val comap : ('a -> 'b) -> 'b t -> 'a t
567	592	(** [comap f p] maps [p], a printer of type ['b], to a printer of type ['a] by
568	593	first converting a printed value using [f : 'a -> 'b]. *)
	594
	595	val tup2 : 'a t -> 'b t -> ('a * 'b) t
	596	(** 2-tuple printer. Expects printers for each component. *)
	597
	598	val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
	599	(** 3-tuple printer. Expects printers for each component. *)
	600
	601	val tup4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
	602	(** 4-tuple printer. Expects printers for each component. *)
	603
	604	val tup5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
	605	(** 5-tuple printer. Expects printers for each component. *)
	606
	607	val tup6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t ->
	608	('a * 'b * 'c * 'd * 'e * 'f) t
	609	(** 6-tuple printer. Expects printers for each component. *)
	610
	611	val tup7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t ->
	612	('a * 'b * 'c * 'd * 'e * 'f * 'g) t
	613	(** 7-tuple printer. Expects printers for each component. *)
	614
	615	val tup8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t ->
	616	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
	617	(** 8-tuple printer. Expects printers for each component. *)
	618
	619	val tup9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t ->
	620	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
	621	(** 9-tuple printer. Expects printers for each component. *)
569	622	end
570	623
571	624	(** {2 Iterators}

681	734
682	735	val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
683	736	(** Similar to {!pair} *)
	737
	738	val tup2 : 'a t -> 'b t -> ('a * 'b) t
	739	(** [tup2 a b] uses [a] to shrink the first element of tuples,
	740	then tries to shrink the second element using [b].
	741	It is often better, when generating tuples, to put the "simplest"
	742	element first (atomic type rather than list, etc.) because it will be
	743	shrunk earlier. In particular, putting functions last might help. *)
	744
	745	val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
	746	(** Similar to {!tup2} *)
	747
	748	val tup4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
	749	(** Similar to {!tup2} *)
	750
	751	val tup5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
	752	(** Similar to {!tup2} *)
	753
	754	val tup6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t ->
	755	('a * 'b * 'c * 'd * 'e * 'f) t
	756	(** Similar to {!tup2} *)
	757
	758	val tup7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t ->
	759	('a * 'b * 'c * 'd * 'e * 'f * 'g) t
	760	(** Similar to {!tup2} *)
	761
	762	val tup8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t ->
	763	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
	764	(** Similar to {!tup2} *)
	765
	766	val tup9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t ->
	767	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
	768	(** Similar to {!tup2} *)
684	769	end
685	770
686	771	(** {2 Observe Values} *)

903	988	val make_cell :
904	989	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
905	990	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
906		?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) ->
907		'a cell
	991	?small:('a -> int) -> ?retries:int -> ?name:string ->
	992	'a arbitrary -> ('a -> bool) -> 'a cell
908	993	(** [make_cell arb prop] builds a test that checks property [prop] on instances
909	994	of the generator [arb].
910	995	@param name the name of the test.
911	996	@param count number of test cases to run, counting only
912	997	the test cases which satisfy preconditions.
	998	@param retries number of times to retry the tested property while shrinking.
913	999	@param long_factor the factor by which to multiply count, max_gen and
914	1000	max_fail when running a long test (default: 1).
915	1001	@param max_gen maximum number of times the generation function

950	1036	val make :
951	1037	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
952	1038	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
953		?small:('a -> int) -> ?name:string -> 'a arbitrary -> ('a -> bool) -> t
	1039	?small:('a -> int) -> ?retries:int -> ?name:string -> 'a arbitrary ->
	1040	('a -> bool) -> t
954	1041	(** [make arb prop] builds a test that checks property [prop] on instances
955	1042	of the generator [arb].
956	1043	See {!make_cell} for a description of the parameters.

972	1059	?rand:Random.State.t -> 'a cell -> 'a TestResult.t
973	1060
974	1061	val check_cell_exn :
975		?long:bool -> ?call:'a callback -> ?step:'a step ->
	1062	?long:bool -> ?call:'a callback ->
	1063	?step:'a step -> ?handler:'a handler ->
976	1064	?rand:Random.State.t -> 'a cell -> unit
977	1065
978	1066	val check_exn : ?long:bool -> ?rand:Random.State.t -> t -> unit

1108	1196	valid latin-1). *)
1109	1197
1110	1198	val printable_char : char arbitrary
1111		(** Uniformly distributed over a subset of chars. *)
1112		(* FIXME: describe which subset. *)
	1199	(** Uniformly distributed over a subset of printable ascii chars.
	1200	Ascii character codes 32 to 127.
	1201	*)
1113	1202
1114	1203	val numeral_char : char arbitrary
1115	1204	(** Uniformly distributed over ['0'..'9']. *)
1116	1205
1117	1206	val string_gen_of_size : int Gen.t -> char Gen.t -> string arbitrary
	1207	(** Builds a string generator from a (non-negative) size generator and a character generator. *)
1118	1208
1119	1209	val string_gen : char Gen.t -> string arbitrary
1120		(** Generates strings with a distribution of length of [small_nat]. *)
	1210	(** Generates strings with a distribution of length of {!Gen.nat}. *)
1121	1211
1122	1212	val string : string arbitrary
1123		(** Generates strings with a distribution of length of [small_nat]
	1213	(** Generates strings with a distribution of length of {!Gen.nat}
1124	1214	and distribution of characters of [char]. *)
1125	1215
1126	1216	val small_string : string arbitrary

1131	1221	@since 0.5.3 *)
1132	1222
1133	1223	val string_of_size : int Gen.t -> string arbitrary
1134		(** Generates strings with distribution of characters if [char]. *)
	1224	(** Generates strings with distribution of characters of [char]. *)
1135	1225
1136	1226	val printable_string : string arbitrary
1137		(** Generates strings with a distribution of length of [small_nat]
	1227	(** Generates strings with a distribution of length of {!Gen.nat}
1138	1228	and distribution of characters of [printable_char]. *)
1139	1229
1140	1230	val printable_string_of_size : int Gen.t -> string arbitrary
1141	1231	(** Generates strings with distribution of characters of [printable_char]. *)
1142	1232
1143	1233	val small_printable_string : string arbitrary
	1234	(** Generates strings with a length of [small_nat]
	1235	and distribution of characters of [printable_char]. *)
1144	1236
1145	1237	val numeral_string : string arbitrary
1146		(** Generates strings with a distribution of length of [small_nat]
	1238	(** Generates strings with a distribution of length of {!Gen.nat}
1147	1239	and distribution of characters of [numeral_char]. *)
1148	1240
1149	1241	val numeral_string_of_size : int Gen.t -> string arbitrary
1150	1242	(** Generates strings with a distribution of characters of [numeral_char]. *)
1151	1243
1152	1244	val list : 'a arbitrary -> 'a list arbitrary
1153		(** Generates lists with length generated by [small_nat]. *)
	1245	(** Generates lists with length generated by {!Gen.nat}. *)
1154	1246
1155	1247	val list_of_size : int Gen.t -> 'a arbitrary -> 'a list arbitrary
1156	1248	(** Generates lists with length from the given distribution. *)
1157	1249
1158	1250	val array : 'a arbitrary -> 'a array arbitrary
1159		(** Generates arrays with length generated by [small_nat]. *)
	1251	(** Generates arrays with length generated by {!Gen.nat}. *)
1160	1252
1161	1253	val array_of_size : int Gen.t -> 'a arbitrary -> 'a array arbitrary
1162	1254	(** Generates arrays with length from the given distribution. *)

1173	1265	(** Combines four generators into a generator of 4-tuples.
1174	1266	Order matters for shrinking, see {!Shrink.pair} and the likes *)
1175	1267
	1268	(** {3 Tuple of generators} *)
	1269
	1270	(** {4 Shrinks on [gen1], then [gen2], then ... } *)
	1271
	1272	val tup2 :
	1273	'a arbitrary ->
	1274	'b arbitrary ->
	1275	('a * 'b) arbitrary
	1276	(** Combines two generators into a 2-tuple generator.
	1277	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1278	Prints as many elements as available printers *)
	1279
	1280	val tup3 :
	1281	'a arbitrary ->
	1282	'b arbitrary ->
	1283	'c arbitrary ->
	1284	('a * 'b * 'c) arbitrary
	1285	(** Combines three generators into a 3-tuple generator.
	1286	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1287	Prints as many elements as available printers *)
	1288
	1289	val tup4 :
	1290	'a arbitrary ->
	1291	'b arbitrary ->
	1292	'c arbitrary ->
	1293	'd arbitrary ->
	1294	('a * 'b * 'c * 'd) arbitrary
	1295	(** Combines four generators into a 4-tuple generator.
	1296	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1297	Prints as many elements as available printers *)
	1298
	1299	val tup5 : 'a arbitrary ->
	1300	'b arbitrary ->
	1301	'c arbitrary ->
	1302	'd arbitrary ->
	1303	'e arbitrary ->
	1304	('a * 'b * 'c * 'd * 'e) arbitrary
	1305	(** Combines five generators into a 5-tuple generator.
	1306	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1307	Prints as many elements as available printers *)
	1308
	1309	val tup6 :
	1310	'a arbitrary ->
	1311	'b arbitrary ->
	1312	'c arbitrary ->
	1313	'd arbitrary ->
	1314	'e arbitrary ->
	1315	'f arbitrary ->
	1316	('a * 'b * 'c * 'd * 'e * 'f) arbitrary
	1317	(** Combines six generators into a 6-tuple generator.
	1318	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1319	Prints as many elements as available printers *)
	1320
	1321	val tup7 :
	1322	'a arbitrary ->
	1323	'b arbitrary ->
	1324	'c arbitrary ->
	1325	'd arbitrary ->
	1326	'e arbitrary ->
	1327	'f arbitrary ->
	1328	'g arbitrary ->
	1329	('a * 'b * 'c * 'd * 'e * 'f * 'g) arbitrary
	1330	(** Combines seven generators into a 7-tuple generator.
	1331	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1332	Prints as many elements as available printers *)
	1333
	1334	val tup8 :
	1335	'a arbitrary ->
	1336	'b arbitrary ->
	1337	'c arbitrary ->
	1338	'd arbitrary ->
	1339	'e arbitrary ->
	1340	'f arbitrary ->
	1341	'g arbitrary ->
	1342	'h arbitrary ->
	1343	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) arbitrary
	1344	(** Combines eight generators into a 8-tuple generator.
	1345	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1346	Prints as many elements as available printers *)
	1347
	1348	val tup9 :
	1349	'a arbitrary ->
	1350	'b arbitrary ->
	1351	'c arbitrary ->
	1352	'd arbitrary ->
	1353	'e arbitrary ->
	1354	'f arbitrary ->
	1355	'g arbitrary ->
	1356	'h arbitrary ->
	1357	'i arbitrary ->
	1358	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) arbitrary
	1359	(** Combines nine generators into a 9-tuple generator.
	1360	Order of elements can matter (w.r.t shrinking, see {!Shrink.tup2})
	1361	Prints as many elements as available printers *)
	1362
1176	1363	val option : ?ratio:float -> 'a arbitrary -> 'a option arbitrary
1177	1364	(** Choose between returning Some random value with optional ratio, or None. *)
1178	1365
1179	1366	val fun1_unsafe : 'a arbitrary -> 'b arbitrary -> ('a -> 'b) arbitrary
1180	1367	(** Generator of functions of arity 1.
1181	1368	The functions are always pure and total functions:
1182		- when given the same argument (as decided by Pervasives.(=)), it returns the same value
	1369	- when given the same argument (as decided by Stdlib.(=)), it returns the same value
1183	1370	- it never does side effects, like printing or never raise exceptions etc.
1184	1371	The functions generated are really printable.
1185	1372

+174

-11

src/core/QCheck2.ml less more

599	599	let quad (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) : ('a * 'b * 'c * 'd) t =
600	600	(fun a b c d -> (a, b, c, d)) <$> g1 <> g2 <> g3 <*> g4
601	601
	602	let tup2 = pair
	603
	604	let tup3 = triple
	605
	606	let tup4 = quad
	607
	608	let tup5 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) : ('a * 'b * 'c * 'd * 'e) t =
	609	(fun a b c d e -> (a, b, c, d, e)) <$> g1 <> g2 <> g3 <> g4 <> g5
	610
	611	let tup6 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) : ('a * 'b * 'c * 'd * 'e * 'f) t =
	612	(fun a b c d e f -> (a, b, c, d, e, f)) <$> g1 <> g2 <> g3 <> g4 <> g5 <*> g6
	613
	614	let tup7 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g) t =
	615	(fun a b c d e f g -> (a, b, c, d, e, f, g)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7
	616
	617	let tup8 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) (g8 : 'h t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t =
	618	(fun a b c d e f g h -> (a, b, c, d, e, f, g, h)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7 <*> g8
	619
	620	let tup9 (g1 : 'a t) (g2 : 'b t) (g3 : 'c t) (g4 : 'd t) (g5 : 'e t) (g6 : 'f t) (g7 : 'g t) (g8 : 'h t) (g9 : 'i t) : ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t =
	621	(fun a b c d e f g h i -> (a, b, c, d, e, f, g, h, i)) <$> g1 <> g2 <> g3 <> g4 <> g5 <> g6 <> g7 <> g8 <> g9
	622
602	623	(** Don't reuse {!int_range} which is much less performant (many more checks because of the possible range and origins). As a [string] generator may call this hundreds or even thousands of times for a single value, it's worth optimizing. *)
603	624	let char : char t = fun st ->
604	625	let c = RS.int st 256 in

767	788	let contramap f p x = p (f x)
768	789
769	790	let comap = contramap
	791
	792	let default = fun _ -> "<no printer>"
	793
	794	let tup2 p_a p_b (a, b) =
	795	Printf.sprintf "(%s, %s)" (p_a a) (p_b b)
	796
	797	let tup2_opt p_a p_b (a, b) =
	798	let p_a = Option.value ~default p_a in
	799	let p_b = Option.value ~default p_b in
	800	tup2 p_a p_b (a, b)
	801
	802	let tup3 p_a p_b (p_c) (a, b, c) =
	803	Printf.sprintf "(%s, %s, %s)" (p_a a) (p_b b) (p_c c)
	804
	805	let tup3_opt p_a p_b p_c (a, b, c) =
	806	let p_a = Option.value ~default p_a in
	807	let p_b = Option.value ~default p_b in
	808	let p_c = Option.value ~default p_c in
	809	tup3 p_a p_b p_c (a, b, c)
	810
	811	let tup4 p_a p_b p_c p_d (a, b, c, d) =
	812	Printf.sprintf "(%s, %s, %s, %s)"
	813	(p_a a) (p_b b)
	814	(p_c c) (p_d d)
	815
	816	let tup4_opt p_a p_b p_c p_d (a, b, c, d) =
	817	let p_a = Option.value ~default p_a in
	818	let p_b = Option.value ~default p_b in
	819	let p_c = Option.value ~default p_c in
	820	let p_d = Option.value ~default p_d in
	821	tup4 p_a p_b p_c p_d (a, b, c, d)
	822
	823	let tup5 p_a p_b p_c p_d p_e (a, b, c, d, e) =
	824	Printf.sprintf "(%s, %s, %s, %s, %s)"
	825	(p_a a) (p_b b)
	826	(p_c c) (p_d d)
	827	(p_e e)
	828
	829	let tup5_opt p_a p_b p_c p_d p_e (a, b, c, d, e) =
	830	let p_a = Option.value ~default p_a in
	831	let p_b = Option.value ~default p_b in
	832	let p_c = Option.value ~default p_c in
	833	let p_d = Option.value ~default p_d in
	834	let p_e = Option.value ~default p_e in
	835	tup5 p_a p_b p_c p_d p_e (a, b, c, d, e)
	836
	837	let tup6 p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f) =
	838	Printf.sprintf "(%s, %s, %s, %s, %s, %s)"
	839	(p_a a) (p_b b)
	840	(p_c c) (p_d d)
	841	(p_e e) (p_f f)
	842
	843	let tup6_opt p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f) =
	844	let p_a = Option.value ~default p_a in
	845	let p_b = Option.value ~default p_b in
	846	let p_c = Option.value ~default p_c in
	847	let p_d = Option.value ~default p_d in
	848	let p_e = Option.value ~default p_e in
	849	let p_f = Option.value ~default p_f in
	850	tup6 p_a p_b p_c p_d p_e p_f (a, b, c, d, e, f)
	851
	852	let tup7 p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g) =
	853	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s)"
	854	(p_a a) (p_b b)
	855	(p_c c) (p_d d)
	856	(p_e e) (p_f f)
	857	(p_g g)
	858
	859	let tup7_opt p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g) =
	860	let p_a = Option.value ~default p_a in
	861	let p_b = Option.value ~default p_b in
	862	let p_c = Option.value ~default p_c in
	863	let p_d = Option.value ~default p_d in
	864	let p_e = Option.value ~default p_e in
	865	let p_f = Option.value ~default p_f in
	866	let p_g = Option.value ~default p_g in
	867	tup7 p_a p_b p_c p_d p_e p_f p_g (a, b, c, d, e, f, g)
	868
	869	let tup8 p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h) =
	870	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s, %s)"
	871	(p_a a) (p_b b)
	872	(p_c c) (p_d d)
	873	(p_e e) (p_f f)
	874	(p_g g) (p_h h)
	875
	876	let tup8_opt p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h) =
	877	let p_a = Option.value ~default p_a in
	878	let p_b = Option.value ~default p_b in
	879	let p_c = Option.value ~default p_c in
	880	let p_d = Option.value ~default p_d in
	881	let p_e = Option.value ~default p_e in
	882	let p_f = Option.value ~default p_f in
	883	let p_g = Option.value ~default p_g in
	884	let p_h = Option.value ~default p_h in
	885	tup8 p_a p_b p_c p_d p_e p_f p_g p_h (a, b, c, d, e, f, g, h)
	886
	887	let tup9 p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i) =
	888	Printf.sprintf "(%s, %s, %s, %s, %s, %s, %s, %s, %s)"
	889	(p_a a) (p_b b)
	890	(p_c c) (p_d d)
	891	(p_e e) (p_f f)
	892	(p_g g) (p_h h)
	893	(p_i i)
	894
	895	let tup9_opt p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i) =
	896	let p_a = Option.value ~default p_a in
	897	let p_b = Option.value ~default p_b in
	898	let p_c = Option.value ~default p_c in
	899	let p_d = Option.value ~default p_d in
	900	let p_e = Option.value ~default p_e in
	901	let p_f = Option.value ~default p_f in
	902	let p_g = Option.value ~default p_g in
	903	let p_h = Option.value ~default p_h in
	904	let p_i = Option.value ~default p_i in
	905	tup9 p_a p_b p_c p_d p_e p_f p_g p_h p_i (a, b, c, d, e, f, g, h, i)
770	906	end
771	907
772	908	(** {2 Observe Values} *)

1224	1360	long_factor : int; (* multiplicative factor for long test count *)
1225	1361	max_gen : int; (* max number of instances to generate (>= count) *)
1226	1362	max_fail : int; (* max number of failures *)
	1363	retries : int; (* max number of retries during shrinking *)
1227	1364	law : 'a -> bool; (* the law to check *)
1228	1365	gen : 'a Gen.t; (* how to generate/shrink instances *)
1229	1366	print : 'a Print.t option; (* how to print values *)

1272	1409
1273	1410	let make_cell ?(if_assumptions_fail=default_if_assumptions_fail)
1274	1411	?(count) ?(long_factor=1) ?max_gen
1275		?(max_fail=1) ?(name=fresh_name()) ?print ?collect ?(stats=[]) gen law
	1412	?(max_fail=1) ?(retries=1) ?(name=fresh_name()) ?print ?collect ?(stats=[]) gen law
1276	1413	=
1277	1414	let count = global_count count in
1278	1415	let max_gen = match max_gen with None -> count + 200 \| Some x->x in

1284	1421	stats;
1285	1422	max_gen;
1286	1423	max_fail;
	1424	retries;
1287	1425	name;
1288	1426	count;
1289	1427	long_factor;

1293	1431
1294	1432	let make_cell_from_QCheck1 ?(if_assumptions_fail=default_if_assumptions_fail)
1295	1433	?(count) ?(long_factor=1) ?max_gen
1296		?(max_fail=1) ?(name=fresh_name()) ~gen ?shrink ?print ?collect ~stats law
	1434	?(max_fail=1) ?(retries=1) ?(name=fresh_name()) ~gen ?shrink ?print ?collect ~stats law
1297	1435	=
1298	1436	let count = global_count count in
1299	1437	(* Make a "fake" QCheck2 arbitrary with no shrinking *)

1307	1445	stats;
1308	1446	max_gen;
1309	1447	max_fail;
	1448	retries;
1310	1449	name;
1311	1450	count;
1312	1451	long_factor;

1314	1453	qcheck1_shrink = shrink;
1315	1454	}
1316	1455
1317		let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?name ?print ?collect ?stats gen law =
1318		Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?name ?print ?collect ?stats gen law)
	1456	let make ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats gen law =
	1457	Test (make_cell ?if_assumptions_fail ?count ?long_factor ?max_gen ?max_fail ?retries ?name ?print ?collect ?stats gen law)
1319	1458
1320	1459	let test_get_count (Test cell) = get_count cell
1321	1460

1406	1545	\| Run_ok
1407	1546	\| Run_fail of string list
1408	1547
1409		let run_law law x =
	1548	(* run_law is a helper function for testing a property [law] on a
	1549	generated input [x].
	1550
	1551	When passed a ~retries number n>1, the tested property is checked
	1552	n times for each shrunk input candidate. The default value is 1,
	1553	thus causing no change in behaviour.
	1554
	1555	Retrying a property can be useful when testing non-deterministic
	1556	code with QCheck, e.g., for multicore execution. The idea is
	1557	described in
	1558	'Testing a Database for Race Conditions with QuickCheck'
	1559	Hughes and Bolinder, Erlang 2011, Sec.6:
	1560
	1561	"As we explained in section 4, we ensure that tests fail when
	1562	races are present simply by repeating each test a large number of
	1563	times, and by running on a dual core machine. We obtained the
	1564	minimal failing cases in the previous section by repeating each
	1565	test 100 times during shrinking: thus we stopped shrinking a test
	1566	case only when all of its candidate shrinkings passed 100 tests
	1567	in a row." *)
	1568	let run_law ~retries law x =
	1569	let rec loop i = match law x with
	1570	\| false -> Run_fail []
	1571	\| true ->
	1572	if i<=1 then Run_ok else loop (i-1) in
1410	1573	try
1411		if law x then Run_ok else Run_fail []
	1574	loop retries
1412	1575	with User_fail msg -> Run_fail [msg]
1413	1576
1414	1577	(* QCheck1-compatibility code *)

1438	1601	try
1439	1602	incr count;
1440	1603	st.handler st.test.name st.test (Shrinking (steps, !count, x));
1441		begin match run_law st.test.law x with
	1604	begin match run_law ~retries:st.test.retries st.test.law x with
1442	1605	\| Run_fail m when not is_err -> Some (Tree.pure x, Shrink_fail, m)
1443	1606	\| _ -> None
1444	1607	end

1453	1616	try
1454	1617	incr count;
1455	1618	st.handler st.test.name st.test (Shrinking (steps, !count, x));
1456		begin match run_law st.test.law x with
	1619	begin match run_law ~retries:st.test.retries st.test.law x with
1457	1620	\| Run_fail m when not is_err -> Some (x_tree, Shrink_fail, m)
1458	1621	\| _ -> None
1459	1622	end

1531	1694	let res =
1532	1695	try
1533	1696	state.handler state.test.name state.test (Testing input);
1534		begin match run_law state.test.law input with
	1697	begin match run_law ~retries:1 state.test.law input with
1535	1698	\| Run_ok ->
1536	1699	(* one test ok *)
1537	1700	decr_count state;

1767	1930	\| R.Failed_other {msg} ->
1768	1931	raise (Test_fail (cell.name, [msg]))
1769	1932
1770		let check_cell_exn ?long ?call ?step ?rand cell =
1771		let res = check_cell ?long ?call ?step ?rand cell in
	1933	let check_cell_exn ?long ?call ?step ?handler ?rand cell =
	1934	let res = check_cell ?long ?call ?step ?handler ?rand cell in
1772	1935	check_result cell res
1773	1936
1774	1937	let check_exn ?long ?rand (Test cell) = check_cell_exn ?long ?rand cell

+56

-6

src/core/QCheck2.mli less more

624	624
625	625	@since 0.5.1
626	626	*)
	627
	628	(** {3 Tuple of generators} *)
	629
	630	(** {4 Shrinks on [gen1], then [gen2], then ... } *)
	631
	632	val tup2 : 'a t -> 'b t -> ('a * 'b) t
	633
	634	val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
	635
	636	val tup4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
	637
	638	val tup5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
	639
	640	val tup6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> ('a * 'b * 'c * 'd * 'e * 'f) t
	641
	642	val tup7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g) t
	643
	644	val tup8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
	645
	646	val tup9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t -> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
627	647
628	648	(** {3 Convert a structure of generator to a generator of structure} *)
629	649

1035	1055
1036	1056	val comap : ('b -> 'a) -> 'a t -> 'b t
1037	1057	(** @deprecated use {!contramap} instead. *)
	1058
	1059	val tup2 : 'a t -> 'b t -> ('a * 'b) t
	1060	(** 2-tuple printer. Expects printers for each component. *)
	1061
	1062	val tup3 : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
	1063	(** 3-tuple printer. Expects printers for each component. *)
	1064
	1065	val tup4 : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
	1066	(** 4-tuple printer. Expects printers for each component. *)
	1067
	1068	val tup5 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> ('a * 'b * 'c * 'd * 'e) t
	1069	(** 5-tuple printer. Expects printers for each component. *)
	1070
	1071	val tup6 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t ->
	1072	('a * 'b * 'c * 'd * 'e * 'f) t
	1073	(** 6-tuple printer. Expects printers for each component. *)
	1074
	1075	val tup7 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t ->
	1076	('a * 'b * 'c * 'd * 'e * 'f * 'g) t
	1077	(** 7-tuple printer. Expects printers for each component. *)
	1078
	1079	val tup8 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t ->
	1080	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h) t
	1081	(** 8-tuple printer. Expects printers for each component. *)
	1082
	1083	val tup9 : 'a t -> 'b t -> 'c t -> 'd t -> 'e t -> 'f t -> 'g t -> 'h t -> 'i t ->
	1084	('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h * 'i) t
	1085	(** 9-tuple printer. Expects printers for each component. *)
1038	1086	end
1039	1087
1040	1088	(** Shrinking helper functions. *)

1536	1584
1537	1585	val make_cell :
1538	1586	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
1539		?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?name:string ->
1540		?print:'a Print.t -> ?collect:('a -> string) -> ?stats:('a stat list) ->
	1587	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?retries:int ->
	1588	?name:string -> ?print:'a Print.t -> ?collect:('a -> string) -> ?stats:('a stat list) ->
1541	1589	'a Gen.t -> ('a -> bool) ->
1542	1590	'a cell
1543	1591	(** [make_cell gen prop] builds a test that checks property [prop] on instances

1552	1600	preconditions (should be >= count).
1553	1601	@param max_fail maximum number of failures before we stop generating
1554	1602	inputs. This is useful if shrinking takes too much time.
	1603	@param retries number of times to retry the tested property while shrinking.
1555	1604	@param if_assumptions_fail the minimum
1556	1605	fraction of tests that must satisfy the precondition for a success
1557	1606	to be considered valid.

1567	1616	val make_cell_from_QCheck1 :
1568	1617	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
1569	1618	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int ->
1570		?name:string -> gen:(Random.State.t -> 'a) -> ?shrink:('a -> ('a -> unit) -> unit) ->
	1619	?retries:int -> ?name:string -> gen:(Random.State.t -> 'a) -> ?shrink:('a -> ('a -> unit) -> unit) ->
1571	1620	?print:('a -> string) -> ?collect:('a -> string) -> stats:'a stat list -> ('a -> bool) ->
1572	1621	'a cell
1573	1622	(** ⚠️ Do not use, this is exposed for internal reasons only. ⚠️

1597	1646
1598	1647	val make :
1599	1648	?if_assumptions_fail:([`Fatal \| `Warning] * float) ->
1600		?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?name:string ->
1601		?print:('a Print.t) -> ?collect:('a -> string) -> ?stats:('a stat list) ->
	1649	?count:int -> ?long_factor:int -> ?max_gen:int -> ?max_fail:int -> ?retries:int ->
	1650	?name:string -> ?print:('a Print.t) -> ?collect:('a -> string) -> ?stats:('a stat list) ->
1602	1651	'a Gen.t -> ('a -> bool) -> t
1603	1652	(** [make gen prop] builds a test that checks property [prop] on instances
1604	1653	of the generator [gen].

1691	1740	*)
1692	1741
1693	1742	val check_cell_exn :
1694		?long:bool -> ?call:'a callback -> ?step:'a step ->
	1743	?long:bool -> ?call:'a callback ->
	1744	?step:'a step -> ?handler:'a handler ->
1695	1745	?rand:Random.State.t -> 'a cell -> unit
1696	1746	(** Same as {!check_cell} but calls {!check_result} on the result.
1697	1747	@raise Test_error if [res = Error _]

+96

-0

src/ppx_deriving_qcheck/QCheck_generators.ml less more

	0	open Ppxlib
	1
	2	(** This module contains all generators from QCheck used to
	3	derive a type declaration *)
	4
	5	(** {2. Type} *)
	6
	7	let ty = Ldot (Ldot (Lident "QCheck", "Gen"), "t")
	8
	9	(** {2. Primitive generators} *)
	10
	11	let unit loc = [%expr QCheck.Gen.unit]
	12
	13	let int loc = [%expr QCheck.Gen.int]
	14
	15	let string loc = [%expr QCheck.Gen.string]
	16
	17	let char loc = [%expr QCheck.Gen.char]
	18
	19	let bool loc = [%expr QCheck.Gen.bool]
	20
	21	let float loc = [%expr QCheck.Gen.float]
	22
	23	let int32 loc = [%expr QCheck.Gen.ui32]
	24
	25	let int64 loc = [%expr QCheck.Gen.ui64]
	26
	27	let option ~loc e = [%expr QCheck.Gen.opt [%e e]]
	28
	29	let list ~loc e = [%expr QCheck.Gen.list [%e e]]
	30
	31	let array ~loc e = [%expr QCheck.Gen.array [%e e]]
	32
	33	(** {2. Generator combinators} *)
	34
	35	let pure ~loc x = [%expr QCheck.Gen.pure [%e x]]
	36
	37	let frequency ~loc l =
	38	match l with
	39	\| [%expr [([%e? _], [%e? x])]] -> x
	40	\| _ ->
	41	[%expr QCheck.Gen.frequency [%e l]]
	42
	43	let map ~loc pat expr gen =
	44	[%expr QCheck.Gen.map (fun [%p pat] -> [%e expr]) [%e gen]]
	45
	46	let pair ~loc a b =
	47	[%expr QCheck.Gen.pair [%e a] [%e b]]
	48
	49	let triple ~loc a b c =
	50	[%expr QCheck.Gen.triple [%e a] [%e b] [%e c]]
	51
	52	let quad ~loc a b c d=
	53	[%expr QCheck.Gen.quad [%e a] [%e b] [%e c] [%e d]]
	54
	55	let sized ~loc e =
	56	[%expr QCheck.Gen.sized @@ [%e e]]
	57
	58	let fix ~loc e =
	59	[%expr QCheck.Gen.fix [%e e]]
	60
	61	(** Observable generators *)
	62	module Observable = struct
	63	(** {2. Primitive generators} *)
	64	let unit loc = [%expr QCheck.Observable.unit]
	65
	66	let int loc = [%expr QCheck.Observable.int]
	67
	68	let string loc = [%expr QCheck.Observable.string]
	69
	70	let char loc = [%expr QCheck.Observable.char]
	71
	72	let bool loc = [%expr QCheck.Observable.bool]
	73
	74	let float loc = [%expr QCheck.Observable.float]
	75
	76	let int32 loc = [%expr QCheck.Observable.int32]
	77
	78	let int64 loc = [%expr QCheck.Observable.int64]
	79
	80	let option ~loc e = [%expr QCheck.Observable.option [%e e]]
	81
	82	let list ~loc e = [%expr QCheck.Observable.list [%e e]]
	83
	84	let array ~loc e = [%expr QCheck.Observable.array [%e e]]
	85
	86	(** {2. Observable combinators} *)
	87	let pair ~loc a b =
	88	[%expr QCheck.Observable.pair [%e a] [%e b]]
	89
	90	let triple ~loc a b c =
	91	[%expr QCheck.Observable.triple [%e a] [%e b] [%e c]]
	92
	93	let quad ~loc a b c d=
	94	[%expr QCheck.Observable.quad [%e a] [%e b] [%e c] [%e d]]
	95	end

+331

-0

src/ppx_deriving_qcheck/README.md less more

	0	# ppx_deriving_qcheck
	1
	2	## Generator
	3	Derive `QCheck.Gen.t` from a type declaration
	4
	5	```ocaml
	6	type tree = Leaf of int \| Node of tree * tree
	7	[@@deriving qcheck]
	8
	9	let rec rev tree = match tree with
	10	\| Leaf _ -> tree
	11	\| Node (left, right) -> Node (rev right, rev left)
	12
	13	let test =
	14	QCheck.Test.make
	15	~name:"tree -> rev (rev tree) = tree"
	16	(QCheck.make gen_tree)
	17	(fun tree -> rev (rev tree) = tree)
	18	```
	19
	20	For `type tree` we derive two generators:
	21	- `val gen_tree : tree Gen.t` and
	22	- `val gen_tree_sized : int -> tree Gen.t`
	23
	24	For non-recursive types the latter is however not derived.
	25
	26	For types with the name `t` (i.e. `type t = ...`) which is a common idiom in OCaml code,
	27	the deriver omits the name from the derived generators,
	28	thus producing `val gen : t Gen.t` and optionally `val gen_sized : int -> t Gen.t`.
	29
	30	### Overwrite generator
	31	If you wan't to specify your own `generator` for any type you can
	32	add an attribute to the type:
	33
	34	```ocaml
	35	type t = (int : [@gen QCheck.Gen.(0 -- 10)])
	36	[@@deriving qcheck]
	37
	38	(* produces ==> *)
	39
	40	let gen : t QCheck.Gen.t = QCheck.Gen.(0 -- 10)
	41	```
	42
	43	This attribute has 2 advantages:
	44	* Use your own generator for a specific type (see above)
	45	* There is no generator available for the type
	46	```ocaml
	47	type my_foo =
	48	\| Foo of my_other_type
	49	\| Bar of bool
	50	[@@deriving qcheck]
	51	^^^^^^^^^^^^^^^^
	52	Error: Unbound value gen_my_other_type
	53
	54	(* Possible fix *)
	55	let gen_my_other_type = (* add your implementation here *)
	56
	57	type my_foo =
	58	\| Foo of my_other_type [@gen gen_my_other_type]
	59	\| Bar of bool
	60	[@@deriving qcheck]
	61	```
	62
	63	## How to use
	64
	65	Add to your OCaml libraries with dune
	66	```ocaml
	67	...
	68	(preprocess (pps ppx_deriving_qcheck)))
	69	...
	70	```
	71
	72	## Supported types
	73
	74	### Primitive types
	75
	76	* Unit
	77	```ocaml
	78	type t = unit [@@deriving qcheck]
	79
	80	(* ==> *)
	81
	82	let gen = QCheck.Gen.unit
	83	```
	84
	85	* Bool
	86	```ocaml
	87	type t = bool [@@deriving qcheck]
	88
	89	(* ==> *)
	90
	91	let gen = QCheck.Gen.bool
	92	```
	93
	94	* Integer
	95	```ocaml
	96	type t = int [@@deriving qcheck]
	97
	98	(* ==> *)
	99
	100	let gen = QCheck.Gen.int
	101	```
	102
	103	* Float
	104	```ocaml
	105	type t = float [@@deriving qcheck]
	106
	107	(* ==> *)
	108
	109	let gen = QCheck.Gen.float
	110	```
	111
	112	* String
	113	```ocaml
	114	type t = string [@@deriving qcheck]
	115
	116	(* ==> *)
	117
	118	let gen = QCheck.Gen.string
	119	```
	120
	121	* Char
	122	```ocaml
	123	type t = char [@@deriving qcheck]
	124
	125	(* ==> *)
	126
	127	let gen = QCheck.Gen.char
	128	```
	129
	130	* Option
	131	```ocaml
	132	type 'a t = 'a option [@@deriving qcheck]
	133
	134	(* ==> *)
	135
	136	let gen gen_a = QCheck.Gen.option gen_a
	137	```
	138
	139	* List
	140	```ocaml
	141	type 'a t = 'a list [@@deriving qcheck]
	142
	143	(* ==> *)
	144
	145	let gen gen_a = QCheck.Gen.list gen_a
	146	```
	147
	148	* Array
	149	```ocaml
	150	type 'a t = 'a array [@@deriving qcheck]
	151
	152	(* ==> *)
	153
	154	let gen gen_a = QCheck.Gen.array gen_a
	155	```
	156
	157	### Tuples of size `n`
	158
	159	* n = 2
	160	```ocaml
	161	type t = int * int [@@deriving qcheck]
	162
	163	(* ==> *)
	164
	165	let gen = QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int
	166	```
	167
	168	* n = 3
	169	```ocaml
	170	type t = int * int * int [@@deriving qcheck]
	171
	172	(* ==> *)
	173
	174	let gen = QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int
	175	```
	176
	177	* n = 4
	178	```ocaml
	179	type t = int * int * int * int [@@deriving qcheck]
	180
	181	(* ==> *)
	182
	183	let gen = QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int
	184	```
	185
	186	* n > 4, tuples are split between pairs, for instance n = 8
	187	```ocaml
	188	type t = int * int * int * int * int * int * int * int [@@deriving qcheck]
	189
	190	(* ==> *)
	191
	192	let gen =
	193	QCheck.Gen.pair
	194	(QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)
	195	(QCheck.Gen.quad QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)
	196	```
	197
	198	## Records
	199	```ocaml
	200	type service = {
	201	service_name : string;
	202	port : int;
	203	protocol : string;
	204	} [@@deriving qcheck]
	205
	206	(* ==> *)
	207
	208	let gen_service =
	209	QCheck.Gen.map
	210	(fun (gen0, gen1, gen2) ->
	211	{ service_name = gen0; port = gen1; protocol = gen2 })
	212	(QCheck.Gen.triple QCheck.Gen.string QCheck.Gen.int QCheck.Gen.string)
	213	```
	214
	215	## Variants
	216	* Variants
	217	```ocaml
	218	type color = Red \| Blue \| Green
	219	[@@deriving qcheck]
	220
	221	(* ==> *)
	222
	223	let gen_color =
	224	QCheck.Gen.frequency
	225	[(1, (QCheck.Gen.pure Red));
	226	(1, (QCheck.Gen.pure Blue));
	227	(1, (QCheck.Gen.pure Green))]
	228	```
	229
	230	* Polymorphic variants
	231	```ocaml
	232	type color = [ `Red \| `Blue \| `Green ]
	233	[@@deriving qcheck]
	234
	235	(* ==> *)
	236
	237	let gen_color =
	238	(QCheck.Gen.frequency
	239	[(1, (QCheck.Gen.pure `Red));
	240	(1, (QCheck.Gen.pure `Blue));
	241	(1, (QCheck.Gen.pure `Green))] : color QCheck.Gen.t)
	242	```
	243
	244	## Recursive variants
	245	* Recursive variants
	246	```ocaml
	247	type tree = Leaf of int \| Node of tree * tree
	248	[@@deriving qcheck]
	249
	250	(* ==> *)
	251
	252	let rec gen_tree_sized n =
	253	match n with
	254	\| 0 -> QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int
	255	\| n ->
	256	QCheck.Gen.frequency
	257	[(1, (QCheck.Gen.map (fun gen0 -> Leaf gen0) QCheck.Gen.int));
	258	(1,
	259	(QCheck.Gen.map (fun (gen0, gen1) -> Node (gen0, gen1))
	260	(QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))]))
	261
	262	let gen_tree = QCheck.Gen.sized @@ gen_tree_sized
	263	```
	264
	265	* Recursive polymorphic variants
	266	```ocaml
	267	type tree = [ `Leaf of int \| `Node of tree * tree ]
	268	[@@deriving qcheck]
	269
	270	(* ==> *)
	271
	272	let gen_tree =
	273	(QCheck.Gen.sized @@ QCheck.Gen.fix (fun self -> function
	274	\| 0 ->
	275	QCheck.Gen.frequency [
	276	( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int);
	277	]
	278	\| n ->
	279	QCheck.Gen.frequency [
	280	( 1, QCheck.Gen.map (fun gen0 -> `Leaf gen0) QCheck.Gen.int);
	281	( 1,
	282	QCheck.Gen.map (fun gen0 -> `Node gen0)
	283	(QCheck.Gen.map
	284	(fun (gen0, gen1) -> (gen0, gen1))
	285	(QCheck.Gen.pair (self (n / 2)) (self (n / 2)))))
	286	])
	287	: tree QCheck.Gen.t)
	288	```
	289
	290	## Mutual recursive types
	291	```ocaml
	292	type tree = Node of (int * forest)
	293	and forest = Nil \| Cons of (tree * forest)
	294	[@@deriving qcheck]
	295
	296	(* ==> *)
	297
	298	let rec gen_tree () =
	299	QCheck.Gen.frequency
	300	[(1,
	301	(QCheck.Gen.map (fun gen0 -> Node gen0)
	302	(QCheck.Gen.map (fun (gen0, gen1) -> (gen0, gen1))
	303	(QCheck.Gen.pair QCheck.Gen.int (gen_forest ())))))]
	304
	305	and gen_forest () =
	306	QCheck.Gen.sized @@
	307	(QCheck.Gen.fix
	308	(fun self -> function
	309	\| 0 -> QCheck.Gen.frequency [(1, (QCheck.Gen.pure Nil))]
	310	\| n ->
	311	QCheck.Gen.frequency
	312	[(1, (QCheck.Gen.pure Nil));
	313	(1,
	314	(QCheck.Gen.map (fun gen0 -> Cons gen0)
	315	(QCheck.Gen.map (fun (gen0, gen1) -> (gen0, gen1))
	316	(QCheck.Gen.pair (gen_tree ()) (self (n / 2))))))]))
	317
	318	let gen_tree = gen_tree ()
	319
	320	let gen_forest = gen_forest ()
	321	```
	322
	323	## Unsupported types
	324
	325	### GADT
	326	Deriving a GADT currently produces an ill-typed generator.
	327
	328	### Let us know
	329	If you encounter a unsupported type (that should be), please let us know by creating
	330	an issue.

+24

-0

src/ppx_deriving_qcheck/args.ml less more

	0	open Ppxlib
	1
	2	(** [curry_args args body] adds parameter to [body]
	3
	4	e.g.:
	5	curry_args [gen_a; gen_b] () => fun gen_a -> fun gen_b -> ()
	6	*)
	7	let rec curry_args ~loc args body =
	8	match args with
	9	\| [] -> body
	10	\| x :: xs -> [%expr fun [%p x] -> [%e curry_args ~loc xs body]]
	11
	12	(** [apply_args args body] applies parameters to [body]
	13
	14	e.g.:
	15	apply_args [gen_a; gen_b] f => f gen_a gen_b
	16	*)
	17	let apply_args ~loc args body =
	18	let rec aux acc = function
	19	\| [] -> acc
	20	\| [arg] -> [%expr [%e acc] [%e arg]]
	21	\| arg :: args -> aux [%expr [%e acc] [%e arg]] args
	22	in
	23	aux body args

+19

-0

src/ppx_deriving_qcheck/attributes.ml less more

	0	open Ppxlib
	1
	2	(** [find_first_attribute xs name] returns the first attribute found in [xs]
	3	named [name] *)
	4	let find_attribute_opt xs name =
	5	List.find_opt (fun attribute -> attribute.attr_name.txt = name) xs
	6
	7	let get_expr_payload x =
	8	match x.attr_payload with
	9	\| PStr [ { pstr_desc = Pstr_eval (e, _); _ } ] -> Some [%expr [%e e]]
	10	\| _ -> None
	11
	12	let gen ct =
	13	Option.fold ~none:None ~some:get_expr_payload
	14	@@ find_attribute_opt ct.ptyp_attributes "gen"
	15
	16	let weight xs =
	17	Option.fold ~none:None ~some:get_expr_payload
	18	@@ find_attribute_opt xs "weight"

+28

-0

src/ppx_deriving_qcheck/attributes.mli less more

	0	open Ppxlib
	1	(** This file handles every attributes to be found in a core_type definition *)
	2
	3	val gen : core_type -> expression option
	4	(** [gen loc ct] look for an attribute "gen" in [ct]
	5
	6	example:
	7	{[
	8	type t =
	9	\| A of int
	10	\| B of (int [@gen QCheck.int32])
	11	]}
	12
	13	It allows the user to specify which generator he wants for a specific type.
	14	Returns the generator as an expression and returns None if no attribute
	15	is present *)
	16
	17	val weight : attributes -> expression option
	18	(** [weight loc ct] look for an attribute "weight" in [ct]
	19
	20	example:
	21	{[
	22	type t =
	23	\| A [@weight 5]
	24	\| B [@weight 6]
	25	\| C
	26	]}
	27	It allows the user to specify the weight of a type case. *)

-0

src/ppx_deriving_qcheck/dune less more

	0	(library
	1	(name ppx_deriving_qcheck)
	2	(public_name ppx_deriving_qcheck)
	3	(libraries ppxlib)
	4	(preprocess (pps ppxlib.metaquot))
	5	(ppx_runtime_libraries qcheck-core)
	6	(kind ppx_deriver))

+526

-0

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml less more

	0	open Ppxlib
	1	module G = QCheck_generators
	2	module O = G.Observable
	3
	4	(** {1. ppx_deriving_qcheck} *)
	5
	6	(** ppx_deriving_qcheck is a ppx deriver for QCheck generators. It does a
	7	traversal map on type declarations annoted with [QCheck].
	8
	9	Example:
	10	{[
	11	module Tree : sig
	12	type t
	13
	14	val gen : t QCheck.Gen.t
	15	end = struct
	16	type t = Leaf \| Node of int * t * t
	17	[@@deriving qcheck]
	18	end
	19	]}
	20	*)
	21
	22	(** {2. Misc. helpers} *)
	23
	24	(** [name s] produces the generator name based on [s] *)
	25	let name ?(sized = false) s =
	26	let prefix = "gen" in
	27	(match s with "t" -> prefix \| s -> prefix ^ "_" ^ s) ^
	28	(if sized then "_sized" else "")
	29
	30	(** [pat ~loc s] creates a pattern for a generator based on {!name}. *)
	31	let pat ~loc ?sized s =
	32	let (module A) = Ast_builder.make loc in
	33	let s = name ?sized s in
	34	A.pvar s
	35
	36	(** {2. Recursive generators} *)
	37
	38	(** Recursive generators must be treated separatly:
	39
	40	{[
	41	type 'a list = Cons of 'a * 'a list \| Nil
	42	]}
	43
	44	becomes:
	45
	46	{[
	47	let rec gen_list_sized gen_a n =
	48	match n with
	49	\| 0 -> pure Nil
	50	\| n -> map2 (fun x xs -> Cons (x, xs) gen_a (gen_list_sized gen_a (n/2))
	51
	52	let gen_list_sized gen_a = sized @@ (gen_list_sized gen_a)
	53	]}
	54
	55	In the basic derivation {[ 'a list ]} would be translated to {[gen_list]}.
	56	However, we want the generator to call itsef.
	57	*)
	58
	59	module Env = struct
	60	(** [env] contains:
	61	- the list of recursive types during the derivation
	62	- the list of types to derive (i.e. mutual types)
	63	- the current type to derive *)
	64	type env = {
	65	rec_types : string list;
	66	curr_types : string list;
	67	curr_type : string;
	68	}
	69
	70	let is_rec env x = List.mem x env.rec_types
	71	end
	72
	73	let rec longident_to_str = function
	74	\| Lident s -> s
	75	\| Ldot (lg, s) -> Printf.sprintf "%s.%s" (longident_to_str lg) s
	76	\| Lapply (lg1, lg2) ->
	77	Printf.sprintf "%s %s" (longident_to_str lg1) (longident_to_str lg2)
	78
	79	let rec is_rec_typ env = function
	80	\| { ptyp_desc = Ptyp_constr ({ txt = x; _ }, _); _ } ->
	81	List.exists (fun typ_name -> longident_to_str x = typ_name) env.Env.curr_types
	82	\| { ptyp_desc = Ptyp_tuple xs; _ } -> List.exists (is_rec_typ env) xs
	83	\| { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
	84	List.exists (is_rec_row_field env) rws
	85	\| _ -> false
	86
	87	and is_rec_row_field env rw =
	88	match rw.prf_desc with
	89	\| Rtag (lab, _, cts) ->
	90	List.exists (fun typ_name -> lab.txt = typ_name) env.Env.curr_types \|\|
	91	List.exists (is_rec_typ env) cts
	92	\| Rinherit ct -> is_rec_typ env ct
	93
	94	let is_rec_constr_decl env cd =
	95	match cd.pcd_args with
	96	\| Pcstr_tuple cts -> List.exists (is_rec_typ env) cts
	97	\| _ -> false
	98
	99	(** [is_rec_type_decl env typ] looks for elements of [env.curr_types]
	100	recursively in [typ]. *)
	101	let is_rec_type_decl env typ =
	102	let in_type_kind =
	103	match typ.ptype_kind with
	104	\| Ptype_variant cstrs -> List.exists (is_rec_constr_decl env) cstrs
	105	\| _ -> false
	106	in
	107	let in_manifest =
	108	match typ.ptype_manifest with
	109	\| Some x -> is_rec_typ env x
	110	\| None -> false
	111	in
	112	in_type_kind \|\| in_manifest
	113
	114
	115	(** is_n_used looks for `n` (size indication) in an expression.
	116
	117	For instance:
	118	{[
	119	type foo = A of bar \| B of bar
	120	and bar = Any
	121	[@@deriving qcheck]
	122
	123	let rec gen_sized_foo n =
	124	let open QCheck.Gen in
	125	frequency [
	126	(map (fun x -> A x) gen_bar);
	127	(map (fun x -> B x) gen_bar);
	128	]
	129	and gen_bar = p
	130	let open QCheck.Gen in
	131	pure Any
	132	]}
	133
	134	The type [foo] is recursive because it has a dependency to [bar] but does
	135	not use the fuel as there is no "leaves" for this type.
	136
	137	We begin by looking for occurences of variables `n`, iff we did not find
	138	any occurences, we replace `n` by `_n` in the generator's parameters. Thus,
	139	avoiding an unused variable.
	140	*)
	141	exception N_is_used
	142
	143	class is_n_used (expr : expression) =
	144	object(self)
	145	inherit Ast_traverse.map as super
	146
	147	method! expression expr =
	148	match expr with
	149	\| [%expr n ] ->
	150	raise N_is_used
	151	\| _ -> super#expression expr
	152
	153	method go () =
	154	match self#expression expr \|> ignore with
	155	\| exception N_is_used -> true
	156	\| () -> false
	157	end
	158
	159	let is_n_used expr = (new is_n_used expr)#go ()
	160
	161	(** {2. Generator constructors} *)
	162
	163	(** [gen_longident lg args] creates a generator using [lg].
	164
	165	The longident can either be a:
	166	- Lident s: We transform to gen_s (or gen if s = "t")
	167	- Ldot (lg, s): We transform to qualified generator (e.g. B.gen)
	168	*)
	169	let gen_longident ~loc ~env lg args =
	170	let (module A) = Ast_builder.make loc in
	171	match lg with
	172	\| Lident s ->
	173	if Env.is_rec env s then
	174	name ~sized:true s \|> A.evar \|>
	175	Args.apply_args ~loc args \|>
	176	Args.apply_args ~loc [ [%expr (n / 2)] ]
	177	else
	178	name s \|> A.evar \|> Args.apply_args ~loc args
	179	\| Ldot (lg, s) ->
	180	A.(pexp_ident (Located.mk @@ Ldot (lg, name s))) \|>
	181	Args.apply_args ~loc args
	182	\| Lapply (_, _) -> raise (Invalid_argument "gen received an Lapply")
	183
	184	(** [gen_sized typ_name is_rec to_gen xs] uses [is_rec] to determine recursive
	185	nodes in [xs].
	186
	187	If no recursive node is found, the type is _not_ recursive, we build a
	188	generator using frequency.
	189
	190	However, if recursive nodes are found, we build a tree like generator using
	191	{!gen_sized}.
	192
	193	The function is generalized for variants and polymorphic variants:
	194
	195	{[
	196	type t = Leaf \| Node of int * t * t
	197
	198	(* or *)
	199
	200	type t = [`Leaf \| `Node of int * t * t]
	201	]}
	202
	203	Therefore, [is_rec] and [to_gen] are different for variants and polymorphic
	204	variants. *)
	205	let gen_sized ~loc (is_rec : 'a -> bool) (to_gen : 'a -> expression) (xs : 'a list) =
	206	let (module A) = Ast_builder.make loc in
	207	let leaves =
	208	List.filter (fun x -> not (is_rec x)) xs \|> List.map to_gen
	209	in
	210	let nodes = List.filter is_rec xs in
	211
	212	if List.length nodes = 0 then
	213	G.frequency ~loc (A.elist leaves)
	214	else if List.length leaves = 0 then
	215	let nodes = List.map to_gen nodes in
	216	G.frequency ~loc (A.elist nodes)
	217	else
	218	let nodes = List.map to_gen nodes in
	219	let leaves = A.elist leaves \|> G.frequency ~loc
	220	and nodes = A.elist (leaves @ nodes) \|> G.frequency ~loc in
	221	[%expr
	222	match n with
	223	\| 0 -> [%e leaves]
	224	\| _ -> [%e nodes]
	225	]
	226
	227	(** [gen_tuple ~loc ?f tys] transforms list of type [tys] into a tuple generator.
	228
	229	[f] can be used to transform tuples, for instance:
	230	{[
	231	type t = Foo of int * int
	232	]}
	233
	234	Without [f]:
	235	{[
	236	let gen = QCheck.Gen.(map (fun (x, y) -> (x, y)) (pair int int))
	237	]}
	238
	239	With [f], building Foo:
	240	{[
	241	let gen = QCheck.Gen.(map (fun (x, y) -> Foo (x, y)) (pair int int))
	242	]}
	243	*)
	244	let gen_tuple ~loc ?(f = fun x -> x) tys =
	245	let tuple = Tuple.from_list tys in
	246	let gen = Tuple.to_gen ~loc tuple in
	247	let expr = Tuple.to_expr ~loc tuple \|> f in
	248	let pat = Tuple.to_pat ~loc tuple in
	249	G.map ~loc pat expr gen
	250
	251	(** [gen_record loc gens ?f label_decls] transforms [gens] and [label_decls] to
	252	a record generator.
	253
	254	Similarly to {!gen_tuple}, we can use [f] to transform records, for instance:
	255	{[
	256	type t = Foo of { left : int; right : int }
	257	]}
	258
	259	Without [f]:
	260	{[
	261	let gen = QCheck.Gen.(map (fun (x, y) -> {left = x; right = y}) (pair int int))
	262	]}
	263
	264	With [f], building Foo:
	265	{[
	266	let gen = QCheck.Gen.(map (fun (x, y) -> Foo {left = x; right = y}) (pair int int))
	267	]}
	268
	269	*)
	270	let gen_record ~loc ~gens ?(f = fun x -> x) xs =
	271	let (module A) = Ast_builder.make loc in
	272	let tuple = Tuple.from_list gens in
	273	let gen = Tuple.to_gen ~loc tuple in
	274	let pat = Tuple.to_pat ~loc tuple in
	275	(* TODO: this should be handled in {!Tuple} *)
	276	let gens =
	277	List.mapi
	278	(fun i _ ->
	279	let s = Printf.sprintf "gen%d" i in
	280	A.evar s)
	281	gens
	282	in
	283	let fields =
	284	List.map2
	285	(fun { pld_name; _ } value ->
	286	(A.Located.mk @@ Lident pld_name.txt, value))
	287	xs gens
	288	in
	289	let expr = A.pexp_record fields None \|> f in
	290
	291	G.map ~loc pat expr gen
	292
	293	(** {2. Core derivation} *)
	294
	295	(** [gen_from_type typ] performs the AST traversal and derivation to qcheck generators *)
	296	let rec gen_from_type ~loc ~env typ =
	297	Option.value (Attributes.gen typ)
	298	~default:
	299	(match typ with
	300	\| [%type: unit] -> G.unit loc
	301	\| [%type: int] -> G.int loc
	302	\| [%type: string] \| [%type: String.t] -> G.string loc
	303	\| [%type: char] -> G.char loc
	304	\| [%type: bool] -> G.bool loc
	305	\| [%type: float] -> G.float loc
	306	\| [%type: int32] \| [%type: Int32.t] -> G.int32 loc
	307	\| [%type: int64] \| [%type: Int64.t] -> G.int64 loc
	308	\| [%type: [%t? typ] option] -> G.option ~loc (gen_from_type ~loc ~env typ)
	309	\| [%type: [%t? typ] list] -> G.list ~loc (gen_from_type ~loc ~env typ)
	310	\| [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc ~env typ)
	311	\| { ptyp_desc = Ptyp_tuple typs; _ } ->
	312	let tys = List.map (gen_from_type ~loc ~env) typs in
	313	gen_tuple ~loc tys
	314	\| { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, args); _ } ->
	315	let args = List.map (gen_from_type ~loc ~env) args in
	316	gen_longident ~loc ~env ty args
	317	\| { ptyp_desc = Ptyp_var s; _ } ->
	318	gen_longident ~loc ~env (Lident s) []
	319	\| { ptyp_desc = Ptyp_variant (rws, _, _); _ } ->
	320	gen_from_variant ~loc ~env rws
	321	\| { ptyp_desc = Ptyp_arrow (_, left, right); _ } ->
	322	gen_from_arrow ~loc ~env left right
	323	\| _ ->
	324	Ppxlib.Location.raise_errorf ~loc
	325	"This type is not supported in ppx_deriving_qcheck")
	326
	327	and gen_from_constr ~loc ~env { pcd_name; pcd_args; pcd_attributes; _ } =
	328	let (module A) = Ast_builder.make loc in
	329	let constr_decl =
	330	A.constructor_declaration ~name:pcd_name ~args:pcd_args ~res:None
	331	in
	332	let mk_constr expr = A.econstruct constr_decl (Some expr) in
	333	let weight = Attributes.weight pcd_attributes in
	334	let gen =
	335	match pcd_args with
	336	\| Pcstr_tuple [] \| Pcstr_record [] ->
	337	G.pure ~loc @@ A.econstruct constr_decl None
	338	\| Pcstr_tuple xs ->
	339	let tys = List.map (gen_from_type ~loc ~env) xs in
	340	gen_tuple ~loc ~f:mk_constr tys
	341	\| Pcstr_record xs ->
	342	let tys = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
	343	gen_record ~loc ~f:mk_constr ~gens:tys xs
	344	in
	345
	346	A.pexp_tuple [ Option.value ~default:[%expr 1] weight; gen ]
	347
	348	and gen_from_variant ~loc ~env rws =
	349	let (module A) = Ast_builder.make loc in
	350	let is_rec = is_rec_row_field env in
	351	let to_gen (row : row_field) : expression =
	352	let w =
	353	Attributes.weight row.prf_attributes \|> Option.value ~default:[%expr 1]
	354	in
	355	let gen =
	356	match row.prf_desc with
	357	\| Rinherit typ -> gen_from_type ~loc ~env typ
	358	\| Rtag (label, _, []) -> G.pure ~loc @@ A.pexp_variant label.txt None
	359	\| Rtag (label, _, typs) ->
	360	let f expr = A.pexp_variant label.txt (Some expr) in
	361	gen_tuple ~loc ~f (List.map (gen_from_type ~loc ~env) typs)
	362	in
	363	[%expr [%e w], [%e gen]]
	364	in
	365	let gen = gen_sized ~loc is_rec to_gen rws in
	366	let typ_t = A.ptyp_constr (A.Located.mk @@ Lident env.curr_type) [] in
	367	let typ_gen = A.Located.mk G.ty in
	368	let typ = A.ptyp_constr typ_gen [ typ_t ] in
	369	[%expr ([%e gen] : [%t typ])]
	370
	371	and gen_from_arrow ~loc ~env left right =
	372	let rec observable = function
	373	\| [%type: unit] -> O.unit loc
	374	\| [%type: bool] -> O.bool loc
	375	\| [%type: int] -> O.int loc
	376	\| [%type: float] -> O.float loc
	377	\| [%type: string] -> O.string loc
	378	\| [%type: char] -> O.char loc
	379	\| [%type: [%t? typ] option] -> O.option ~loc (observable typ)
	380	\| [%type: [%t? typ] array] -> O.array ~loc (observable typ)
	381	\| [%type: [%t? typ] list] -> O.list ~loc (observable typ)
	382	\| { ptyp_desc = Ptyp_tuple xs; _ } ->
	383	let obs = List.map observable xs in
	384	Tuple.from_list obs \|> Tuple.to_obs ~loc
	385	\| { ptyp_loc = loc; _ } ->
	386	Ppxlib.Location.raise_errorf ~loc
	387	"This type is not supported in ppx_deriving_qcheck"
	388	in
	389	let rec aux = function
	390	\| { ptyp_desc = Ptyp_arrow (_, x, xs); _ } ->
	391	let res, xs = aux xs in
	392	let obs = observable x in
	393	(res, [%expr [%e obs] @-> [%e xs]])
	394	\| x -> (gen_from_type ~loc ~env x, [%expr o_nil])
	395	in
	396	let x, obs = aux right in
	397	(* TODO: export this in qcheck_generators for https://github.com/c-cube/qcheck/issues/190 *)
	398	let arb = [%expr QCheck.make [%e x]] in
	399	[%expr
	400	QCheck.fun_nary QCheck.Tuple.([%e observable left] @-> [%e obs]) [%e arb]
	401	\|> QCheck.gen]
	402
	403	(** [gen_from_type_declaration loc td] creates a generator from the type declaration.
	404
	405	It returns either `Recursive or `Normal.
	406
	407	- `Normal of expression:
	408	The derived generator is not recursive, we return only the generator.
	409
	410	- `Recursive of expression * expression
	411	The derived generator was recursive (i.e. val gen : n -> t Gen.t), we return
	412	the sized generator version, and a normal generator using this last with
	413	[Gen.sized].
	414	*)
	415	let gen_from_type_declaration ~loc ~env td =
	416	let (module A) = Ast_builder.make loc in
	417	let ty = env.Env.curr_type in
	418	let is_rec = Env.is_rec env ty in
	419
	420	let args =
	421	List.map
	422	(fun (typ, _) ->
	423	match typ.ptyp_desc with
	424	\| Ptyp_var s -> (pat ~loc s, name s \|> A.evar)
	425	\| _ -> assert false)
	426	td.ptype_params
	427	in
	428	let (args_pat, args_expr) = List.split args in
	429
	430	let gen =
	431	match td.ptype_kind with
	432	\| Ptype_variant xs ->
	433	let is_rec cd = is_rec_constr_decl env cd in
	434	gen_sized ~loc is_rec (gen_from_constr ~loc ~env) xs
	435	\| Ptype_record xs ->
	436	let gens = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
	437	gen_record ~loc ~gens xs
	438	\| _ ->
	439	let typ = Option.get td.ptype_manifest in
	440	gen_from_type ~loc ~env typ
	441	in
	442
	443	let pat_gen = pat ~loc ty in
	444	if not is_rec then
	445	let gen = Args.curry_args ~loc args_pat gen in
	446	`Normal [%stri let [%p pat_gen] = [%e gen]]
	447	else
	448	let args =
	449	if is_n_used gen then args_pat @ [A.pvar "n"]
	450	else args_pat @ [A.pvar "_n"]
	451	in
	452	let gen = Args.curry_args ~loc args gen in
	453	let pat_gen_sized = pat ~loc ~sized:true ty in
	454	let gen_sized = name ~sized:true ty \|> A.evar in
	455	let gen_normal =
	456	Args.curry_args ~loc args_pat
	457	(G.sized ~loc (Args.apply_args ~loc args_expr gen_sized))
	458	in
	459	`Recursive (
	460	[%stri let rec [%p pat_gen_sized] = [%e gen]],
	461	[%stri let [%p pat_gen] = [%e gen_normal]]
	462	)
	463
	464	let mutually_recursive_gens ~loc gens =
	465	let (module A) = Ast_builder.make loc in
	466	let to_mutualize_gens =
	467	List.map (function
	468	\| `Recursive (x, _) -> x
	469	\| `Normal x -> x) gens
	470	in
	471	let normal_gens =
	472	List.filter_map (function
	473	\| `Recursive (_, x) -> Some x
	474	\| `Normal _ -> None) gens
	475	in
	476	let gens =
	477	List.map (function
	478	\| [%stri let [%p? pat] = [%e? expr]]
	479	\| [%stri let rec [%p? pat] = [%e? expr]] ->
	480	A.value_binding ~pat ~expr
	481	\| _ -> assert false) to_mutualize_gens
	482	in
	483	let mutual_gens = A.pstr_value Recursive gens in
	484	mutual_gens :: normal_gens
	485
	486	(** [derive_gen ~loc xs] creates generators for type declaration in [xs]. *)
	487	let derive_gen ~loc (xs : rec_flag * type_declaration list) : structure =
	488	let open Env in
	489	let add_if_rec env typ x =
	490	if is_rec_type_decl env typ then
	491	{ env with rec_types = x :: env.rec_types}
	492	else env
	493	in
	494	match xs with
	495	\| (_, [ x ]) ->
	496	let typ_name = x.ptype_name.txt in
	497	let env = { curr_type = typ_name; rec_types = []; curr_types = [typ_name] } in
	498	let env = add_if_rec env x typ_name in
	499	(match gen_from_type_declaration ~loc ~env x with
	500	\| `Recursive (gen_sized, gen) -> [gen_sized; gen]
	501	\| `Normal gen -> [gen])
	502	\| _, xs ->
	503	let typ_names = List.map (fun x -> x.ptype_name.txt) xs in
	504	let env = { curr_type = ""; rec_types = []; curr_types = typ_names } in
	505	let env =
	506	List.fold_left
	507	(fun env x -> add_if_rec env x x.ptype_name.txt)
	508	env xs
	509	in
	510	let gens =
	511	List.map (fun x ->
	512	let env = { env with curr_type = x.ptype_name.txt }in
	513	gen_from_type_declaration ~loc ~env x) xs
	514	in
	515	mutually_recursive_gens ~loc gens
	516
	517	(** {2. Ppxlib machinery} *)
	518
	519	let create_gen ~ctxt (decls : rec_flag * type_declaration list) : structure =
	520	let loc = Expansion_context.Deriver.derived_item_loc ctxt in
	521	derive_gen ~loc decls
	522
	523	let gen_expander = Deriving.Generator.V2.make_noarg create_gen
	524
	525	let _ = Deriving.add "qcheck" ~str_type_decl:gen_expander

-0

src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli less more

	0	open Ppxlib
	1
	2	val derive_gen : loc:location -> rec_flag * type_declaration list -> structure
	3	(** [derive_gen loc xs] derives a generator for each type_declaration in [xs] *)

+135

-0

src/ppx_deriving_qcheck/tuple.ml less more

	0	open Ppxlib
	1	module G = QCheck_generators
	2	module O = G.Observable
	3
	4	(** {1. Tuple } *)
	5
	6	(** This module implements nested tuples based on QCheck tuples generators (or observables):
	7	- [Gen.pair]
	8	- [Gen.triple]
	9	- [Gen.quad]
	10
	11	It can be used to nest large tuples in a generator.
	12	- e.g.
	13	{[
	14	type t = int * int * int
	15	]}
	16
	17	Lets say QCheck does not have combinator to generate a triple. One has to write:
	18
	19	{[
	20	let gen = QCheck.Gen.(map (fun ((x, y), z) -> (x, y, z) (pair (pair int int) int))
	21	]}
	22
	23	We copy this nesting mechanism with this module.
	24	*)
	25
	26	type 'a t =
	27	\| Pair of 'a t * 'a t
	28	\| Triple of 'a * 'a * 'a
	29	\| Quad of 'a * 'a * 'a * 'a
	30	\| Elem of 'a
	31
	32	(** [from_list l] builds an {!'a t}, if len of [l] is greater than 4, the list
	33	is split into a [Pair] of generators. *)
	34	let rec from_list = function
	35	\| [ a; b; c; d ] -> Quad (a, b, c, d)
	36	\| [ a; b; c ] -> Triple (a, b, c)
	37	\| [ a; b ] -> Pair (Elem a, Elem b)
	38	\| [ a ] -> Elem a
	39	\| l ->
	40	let n = List.length l / 2 in
	41	let i = ref 0 in
	42	let l1 =
	43	List.filter
	44	(fun _ ->
	45	let x = !i in
	46	i := x + 1;
	47	x < n)
	48	l
	49	in
	50	i := 0;
	51	let l2 =
	52	List.filter
	53	(fun _ ->
	54	let x = !i in
	55	i := x + 1;
	56	x >= n)
	57	l
	58	in
	59	Pair (from_list l1, from_list l2)
	60
	61	let rec to_list = function
	62	\| Quad (a, b, c, d) -> [ a; b; c; d ]
	63	\| Triple (a, b, c) -> [ a; b; c ]
	64	\| Pair (a, b) -> to_list a @ to_list b
	65	\| Elem a -> [ a ]
	66
	67	(** [to_expr ~loc t] creates a tuple expression based on [t].
	68	[t] is transformed to a list, and each element from the list becomes
	69	a variable referencing a generator.
	70
	71	- e.g.
	72	to_expr (Pair (_, _)) => (gen0, gen1)
	73	*)
	74	let to_expr ~loc t =
	75	let l = to_list t in
	76	let (module A) = Ast_builder.make loc in
	77	List.mapi
	78	(fun i _ ->
	79	let s = Printf.sprintf "gen%d" i in
	80	A.evar s)
	81	l
	82	\|> A.pexp_tuple
	83
	84	(** [nest pair triple quad t] creates a generator expression for [t] using
	85
	86	- [pair] to combine Pair (_, _)
	87	- [triple] to combine Triple (_, _, )
	88	- [quad] to combine Quad (_, _, _, _)
	89	*)
	90	let rec nest ~pair ~triple ~quad = function
	91	\| Quad (a, b, c, d) -> quad a b c d
	92	\| Triple (a, b, c) -> triple a b c
	93	\| Pair (a, b) ->
	94	pair
	95	(nest ~pair ~triple ~quad a)
	96	(nest ~pair ~triple ~quad b)
	97	\| Elem a -> a
	98
	99	(** [to_gen t] creates a Gen.t with generators' combinators *)
	100	let to_gen ~loc t =
	101	nest ~pair:(G.pair ~loc) ~triple:(G.triple ~loc) ~quad:(G.quad ~loc) t
	102
	103	(** [to_obs t] creates a Obs.t with obsersvables' combinators *)
	104	let to_obs ~loc t =
	105	nest ~pair:(O.pair ~loc) ~triple:(O.triple ~loc) ~quad:(O.quad ~loc) t
	106
	107	let to_pat ~loc t =
	108	let fresh_id =
	109	let id = ref 0 in
	110	fun () ->
	111	let x = !id in
	112	let () = id := x + 1 in
	113	Printf.sprintf "gen%d" x
	114	in
	115	let (module A) = Ast_builder.make loc in
	116	let rec aux = function
	117	\| Quad (_, _, _, _) ->
	118	let a = A.pvar @@ fresh_id () in
	119	let b = A.pvar @@ fresh_id () in
	120	let c = A.pvar @@ fresh_id () in
	121	let d = A.pvar @@ fresh_id () in
	122	[%pat? [%p a], [%p b], [%p c], [%p d]]
	123	\| Triple (_, _, _) ->
	124	let a = A.pvar @@ fresh_id () in
	125	let b = A.pvar @@ fresh_id () in
	126	let c = A.pvar @@ fresh_id () in
	127	[%pat? [%p a], [%p b], [%p c]]
	128	\| Pair (a, b) ->
	129	let a = aux a in
	130	let b = aux b in
	131	[%pat? [%p a], [%p b]]
	132	\| Elem _ -> A.pvar @@ fresh_id ()
	133	in
	134	aux t

+16

-19

src/runner/QCheck_base_runner.ml less more

218	218	\| None -> Printf.fprintf out "<no printer provided>"
219	219	\| Some print -> Printf.fprintf out "%s" (print x)
220	220
221		let debug_shrinking_choices_aux ~colors out name i cell x =
	221	let debug_shrinking_choices ~colors ~out ~name cell ~step x =
222	222	Printf.fprintf out "\n~~~ %a %s\n\n"
223	223	(Color.pp_str_c ~colors `Cyan) "Shrink" (String.make 69 '~');
224	224	Printf.fprintf out
225	225	"Test %s successfully shrunk counter example (step %d) to:\n\n%a\n%!"
226		name i
	226	name step
227	227	(debug_shrinking_counter_example cell) x
228
229		let debug_shrinking_choices
230		~colors ~debug_shrink ~debug_shrink_list name cell i x =
231		match debug_shrink with
232		\| None -> ()
233		\| Some out ->
234		begin match debug_shrink_list with
235		\| [] ->
236		debug_shrinking_choices_aux ~colors out name i cell x
237		\| l when List.mem name l ->
238		debug_shrinking_choices_aux ~colors out name i cell x
239		\| _ -> ()
240		end
241
242	228
243	229	let default_handler
244	230	~colors ~debug_shrink ~debug_shrink_list

255	241	in
256	242	(* debug shrinking choices *)
257	243	begin match r with
258		\| QCheck2.Test.Shrunk (i, x) ->
259		debug_shrinking_choices
260		~colors ~debug_shrink ~debug_shrink_list name cell i x
	244	\| QCheck2.Test.Shrunk (step, x) ->
	245	begin match debug_shrink with
	246	\| None -> ()
	247	\| Some out ->
	248	let go =
	249	match debug_shrink_list with
	250	\| [] -> true
	251	\| test_list -> List.mem name test_list
	252	in
	253	if not go then ()
	254	else
	255	debug_shrinking_choices
	256	~colors ~out ~name cell ~step x
	257	end
261	258	\| _ ->
262	259	()
263	260	end;

+10

-0

src/runner/QCheck_base_runner.mli less more

86	86	val default_handler : handler_gen
87	87	(** The default handler used. *)
88	88
	89	val debug_shrinking_choices:
	90	colors:bool ->
	91	out:out_channel ->
	92	name:string -> 'a QCheck2.Test.cell -> step:int -> 'a -> unit
	93	(** The function used by the default handler to debug shrinking choices.
	94	This can be useful to outside users trying to reproduce some of the
	95	base-runner behavior.
	96
	97	@since 0.19
	98	*)
89	99
90	100	(** {2 Run a Suite of Tests and Get Results} *)
91	101

+208

-50

test/core/QCheck2_expect_test.ml less more

64	64	]
65	65	(Gen.int_bound 120) (fun _ -> true)
66	66
	67	let retries =
	68	Test.make ~name:"with shrinking retries" ~retries:10 ~print:Print.int
	69	Gen.small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1)
	70
67	71	let bad_assume_warn =
68	72	Test.make ~name:"WARN_unlikely_precond" ~count:2_000 ~print:Print.int
69	73	Gen.int

78	82	(fun x ->
79	83	QCheck.assume (x mod 100 = 1);
80	84	true)
	85
	86	let tests = [
	87	passing;
	88	failing;
	89	error;
	90	collect;
	91	stats;
	92	retries;
	93	bad_assume_warn;
	94	bad_assume_fail;
	95	]
	96
81	97	end
82	98
83	99	(* positive tests of the various generators *)

129	145	~name:"tree_rev_is_involutive"
130	146	IntTree.gen_tree
131	147	(fun tree -> IntTree.(rev_tree (rev_tree tree)) = tree)
	148
	149	let test_tup2 =
	150	Test.make ~count:10
	151	~name:"forall x in (0, 1): x = (0, 1)"
	152	Gen.(tup2 (pure 0) (pure 1))
	153	(fun x -> x = (0, 1))
	154
	155	let test_tup3 =
	156	Test.make ~count:10
	157	~name:"forall x in (0, 1, 2): x = (0, 1, 2)"
	158	Gen.(tup3 (pure 0) (pure 1) (pure 2))
	159	(fun x -> x = (0, 1, 2))
	160
	161	let test_tup4 =
	162	Test.make ~count:10
	163	~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)"
	164	Gen.(tup4 (pure 0) (pure 1) (pure 2) (pure 3))
	165	(fun x -> x = (0, 1, 2, 3))
	166
	167	let test_tup5 =
	168	Test.make ~count:10
	169	~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)"
	170	Gen.(tup5 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4))
	171	(fun x -> x = (0, 1, 2, 3, 4))
	172
	173	let test_tup6 =
	174	Test.make ~count:10
	175	~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)"
	176	Gen.(tup6 (pure 0) (pure 1) (pure 2) (pure 3) (pure 4) (pure 5))
	177	(fun x -> x = (0, 1, 2, 3, 4, 5))
	178
	179	let test_tup7 =
	180	Test.make ~count:10
	181	~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)"
	182	Gen.(tup7
	183	(pure 0) (pure 1) (pure 2) (pure 3) (pure 4)
	184	(pure 5) (pure 6))
	185	(fun x -> x = (0, 1, 2, 3, 4, 5, 6))
	186
	187	let test_tup8 =
	188	Test.make ~count:10
	189	~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)"
	190	Gen.(tup8
	191	(pure 0) (pure 1) (pure 2) (pure 3) (pure 4)
	192	(pure 5) (pure 6) (pure 7))
	193	(fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7))
	194
	195	let test_tup9 =
	196	Test.make ~count:10
	197	~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)"
	198	Gen.(tup9
	199	(pure 0) (pure 1) (pure 2) (pure 3) (pure 4)
	200	(pure 5) (pure 6) (pure 7) (pure 8))
	201	(fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8))
	202
	203	let tests = [
	204	char_dist_issue_23;
	205	char_test;
	206	nat_test;
	207	string_test;
	208	list_test;
	209	list_repeat_test;
	210	array_repeat_test;
	211	passing_tree_rev;
	212	test_tup2;
	213	test_tup3;
	214	test_tup4;
	215	test_tup5;
	216	test_tup6;
	217	test_tup7;
	218	test_tup8;
	219	test_tup9;
	220	]
132	221	end
133	222
134	223	(* negative tests that exercise shrinking behaviour *)

235	324	Test.make ~name:"tree contains only 42" ~print:IntTree.print_tree
236	325	IntTree.gen_tree
237	326	(fun tree -> IntTree.contains_only_n tree 42)
	327
	328	let test_tup2 =
	329	Test.make
	330	~print:Print.(tup2 int int)
	331	~name:"forall (a, b) in nat: a < b"
	332	Gen.(tup2 small_int small_int)
	333	(fun (a, b) -> a < b)
	334
	335	let test_tup3 =
	336	Test.make
	337	~print:Print.(tup3 int int int)
	338	~name:"forall (a, b, c) in nat: a < b < c"
	339	Gen.(tup3 small_int small_int small_int)
	340	(fun (a, b, c) -> a < b && b < c)
	341
	342	let test_tup4 =
	343	Test.make
	344	~print:Print.(tup4 int int int int)
	345	~name:"forall (a, b, c, d) in nat: a < b < c < d"
	346	Gen.(tup4 small_int small_int small_int small_int)
	347	(fun (a, b, c, d) -> a < b && b < c && c < d)
	348
	349	let test_tup5 =
	350	Test.make
	351	~print:Print.(tup5 int int int int int)
	352	~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e"
	353	Gen.(tup5 small_int small_int small_int small_int small_int)
	354	(fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e)
	355
	356	let test_tup6 =
	357	Test.make
	358	~print:Print.(tup6 int int int int int int)
	359	~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f"
	360	Gen.(tup6 small_int small_int small_int small_int small_int small_int)
	361	(fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f)
	362
	363	let test_tup7 =
	364	Test.make
	365	~print:Print.(tup7 int int int int int int int)
	366	~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g"
	367	Gen.(tup7 small_int small_int small_int small_int small_int small_int small_int)
	368	(fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g)
	369
	370	let test_tup8 =
	371	Test.make
	372	~print:Print.(tup8 int int int int int int int int)
	373	~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h"
	374	Gen.(tup8 small_int small_int small_int small_int small_int small_int small_int small_int)
	375	(fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h)
	376
	377	let test_tup9 =
	378	Test.make
	379	~print:Print.(tup9 int int int int int int int int int)
	380	~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i"
	381	Gen.(tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int)
	382	(fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i)
	383
	384	let tests = [
	385	(test_fac_issue59;)
	386	big_bound_issue59;
	387	long_shrink;
	388	ints_arent_0_mod_3;
	389	ints_are_0;
	390	ints_smaller_209609;
	391	nats_smaller_5001;
	392	char_is_never_abcdef;
	393	strings_are_empty;
	394	string_never_has_000_char;
	395	string_never_has_255_char;
	396	lists_are_empty_issue_64;
	397	list_shorter_10;
	398	list_shorter_432;
	399	list_shorter_4332;
	400	list_equal_dupl;
	401	list_unique_elems;
	402	tree_contains_only_42;
	403	test_tup2;
	404	test_tup3;
	405	test_tup4;
	406	test_tup5;
	407	test_tup6;
	408	test_tup7;
	409	test_tup8;
	410	test_tup9;
	411	]
238	412	end
239	413
240	414	(* tests function generator and shrinker *)

312	486	let f = Fn.apply f in
313	487	List.fold_left f acc (is @ js)
314	488	= List.fold_left f (List.fold_left f acc is) is) (Typo)
	489
	490	let tests = [
	491	fail_pred_map_commute;
	492	fail_pred_strings;
	493	prop_foldleft_foldright;
	494	prop_foldleft_foldright_uncurry;
	495	prop_foldleft_foldright_uncurry_funlast;
	496	fold_left_test;
	497	]
315	498	end
316	499
317	500	(* tests of (inner) find_example(_gen) behaviour *)

336	519	let find_ex_uncaught_issue_99_2_succeed =
337	520	Test.make ~name:"should_succeed_#99_2" ~count:10
338	521	Gen.int (fun i -> i <= max_int)
	522
	523	let tests = [
	524	find_ex;
	525	find_ex_uncaught_issue_99_1_fail;
	526	find_ex_uncaught_issue_99_2_succeed;
	527	]
339	528	end
340	529
341	530	(* tests of statistics and histogram display *)

400	589	let tree_depth_test =
401	590	let depth = ("depth", IntTree.depth) in
402	591	Test.make ~name:"tree's depth" ~count:1000 ~stats:[depth] IntTree.gen_tree (fun _ -> true)
	592
	593	let tests =
	594	[
	595	bool_dist;
	596	char_dist;
	597	tree_depth_test
	598	]
	599	@ string_len_tests
	600	@ list_len_tests
	601	@ array_len_tests
	602	@ int_dist_tests
	603
403	604	end
404	605
405	606	(* Calling runners *)
406	607
407	608	let () = QCheck_base_runner.set_seed 1234
408	609	let _ =
409		QCheck_base_runner.run_tests ~colors:false ([
410		Overall.passing;
411		Overall.failing;
412		Overall.error;
413		Overall.collect;
414		Overall.stats;
415		Overall.bad_assume_warn;
416		Overall.bad_assume_fail;
417		Generator.char_dist_issue_23;
418		Generator.char_test;
419		Generator.nat_test;
420		Generator.string_test;
421		Generator.list_test;
422		Generator.list_repeat_test;
423		Generator.array_repeat_test;
424		Generator.passing_tree_rev;
425		(Shrink.test_fac_issue59;)
426		Shrink.big_bound_issue59;
427		Shrink.long_shrink;
428		Shrink.ints_arent_0_mod_3;
429		Shrink.ints_are_0;
430		Shrink.ints_smaller_209609;
431		Shrink.nats_smaller_5001;
432		Shrink.char_is_never_abcdef;
433		Shrink.strings_are_empty;
434		Shrink.string_never_has_000_char;
435		Shrink.string_never_has_255_char;
436		Shrink.lists_are_empty_issue_64;
437		Shrink.list_shorter_10;
438		Shrink.list_shorter_432;
439		Shrink.list_shorter_4332;
440		Shrink.list_equal_dupl;
441		Shrink.list_unique_elems;
442		Shrink.tree_contains_only_42;
443		Function.fail_pred_map_commute;
444		Function.fail_pred_strings;
445		Function.prop_foldleft_foldright;
446		Function.prop_foldleft_foldright_uncurry;
447		Function.prop_foldleft_foldright_uncurry_funlast;
448		Function.fold_left_test;
449		FindExample.find_ex;
450		FindExample.find_ex_uncaught_issue_99_1_fail;
451		FindExample.find_ex_uncaught_issue_99_2_succeed;
452		Stats.bool_dist;
453		Stats.char_dist;
454		Stats.tree_depth_test ]
455		@ Stats.string_len_tests
456		@ Stats.list_len_tests
457		@ Stats.array_len_tests
458		@ Stats.int_dist_tests)
	610	QCheck_base_runner.run_tests ~colors:false (
	611	Overall.tests @
	612	Generator.tests @
	613	Shrink.tests @
	614	Function.tests @
	615	FindExample.tests @
	616	Stats.tests)
459	617
460	618	let () = QCheck_base_runner.set_seed 153870556
461	619	let _ = QCheck_base_runner.run_tests ~colors:false [Stats.int_dist_empty_bucket]

+204

-56

test/core/QCheck_expect_test.ml less more

66	66	])
67	67	(fun _ -> true)
68	68
	69	let retries =
	70	Test.make ~name:"with shrinking retries" ~retries:10
	71	small_nat (fun i -> Printf.printf "%i %!" i; i mod 3 <> 1)
	72
69	73	let bad_assume_warn =
70	74	Test.make ~name:"WARN_unlikely_precond" ~count:2_000
71	75	int

80	84	(fun x ->
81	85	QCheck.assume (x mod 100 = 1);
82	86	true)
	87
	88	let tests = [
	89	passing;
	90	failing;
	91	error;
	92	collect;
	93	stats;
	94	retries;
	95	bad_assume_warn;
	96	bad_assume_fail;
	97	]
83	98	end
84	99
85	100	(* positive tests of the various generators

211	226	Array.length arr = m
212	227	&& Array.for_all (fun k -> 0 < k) arr
213	228	&& Array.fold_left (+) 0 arr = n)
	229
	230	let test_tup2 =
	231	Test.make ~count:10
	232	~name:"forall x in (0, 1): x = (0, 1)"
	233	(tup2 (always 0) (always 1))
	234	(fun x -> x = (0, 1))
	235
	236	let test_tup3 =
	237	Test.make ~count:10
	238	~name:"forall x in (0, 1, 2): x = (0, 1, 2)"
	239	(tup3 (always 0) (always 1) (always 2))
	240	(fun x -> x = (0, 1, 2))
	241
	242	let test_tup4 =
	243	Test.make ~count:10
	244	~name:"forall x in (0, 1, 2, 3): x = (0, 1, 2, 3)"
	245	(tup4 (always 0) (always 1) (always 2) (always 3))
	246	(fun x -> x = (0, 1, 2, 3))
	247
	248	let test_tup5 =
	249	Test.make ~count:10
	250	~name:"forall x in (0, 1, 2, 3, 4): x = (0, 1, 2, 3, 4)"
	251	(tup5 (always 0) (always 1) (always 2) (always 3) (always 4))
	252	(fun x -> x = (0, 1, 2, 3, 4))
	253
	254	let test_tup6 =
	255	Test.make ~count:10
	256	~name:"forall x in (0, 1, 2, 3, 4, 5): x = (0, 1, 2, 3, 4, 5)"
	257	(tup6 (always 0) (always 1) (always 2) (always 3) (always 4) (always 5))
	258	(fun x -> x = (0, 1, 2, 3, 4, 5))
	259
	260	let test_tup7 =
	261	Test.make ~count:10
	262	~name:"forall x in (0, 1, 2, 3, 4, 5, 6): x = (0, 1, 2, 3, 4, 5, 6)"
	263	(tup7
	264	(always 0) (always 1) (always 2) (always 3) (always 4)
	265	(always 5) (always 6))
	266	(fun x -> x = (0, 1, 2, 3, 4, 5, 6))
	267
	268	let test_tup8 =
	269	Test.make ~count:10
	270	~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7): x = (0, 1, 2, 3, 4, 5, 6, 7)"
	271	(tup8
	272	(always 0) (always 1) (always 2) (always 3) (always 4)
	273	(always 5) (always 6) (always 7))
	274	(fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7))
	275
	276	let test_tup9 =
	277	Test.make ~count:10
	278	~name:"forall x in (0, 1, 2, 3, 4, 5, 6, 7, 8): x = (0, 1, 2, 3, 4, 5, 6, 7, 8)"
	279	(tup9
	280	(always 0) (always 1) (always 2) (always 3) (always 4)
	281	(always 5) (always 6) (always 7) (always 8))
	282	(fun x -> x = (0, 1, 2, 3, 4, 5, 6, 7, 8))
	283
	284	let tests = [
	285	char_dist_issue_23;
	286	char_test;
	287	nat_test;
	288	string_test;
	289	list_test;
	290	list_repeat_test;
	291	array_repeat_test;
	292	passing_tree_rev;
	293	nat_split2_spec;
	294	pos_split2_spec;
	295	range_subset_spec;
	296	nat_split_n_way;
	297	nat_split_smaller;
	298	pos_split;
	299	test_tup2;
	300	test_tup3;
	301	test_tup4;
	302	test_tup5;
	303	test_tup6;
	304	test_tup7;
	305	test_tup8;
	306	test_tup9;
	307	]
214	308	end
215	309
216	310	(* negative tests that exercise shrinking behaviour *)

310	404	(list small_int)
311	405	(fun xs -> let ys = List.sort_uniq Int.compare xs in
312	406	print_list xs; List.length xs = List.length ys)
	407
	408	let test_tup2 =
	409	Test.make
	410	~name:"forall (a, b) in nat: a < b"
	411	(tup2 small_int small_int)
	412	(fun (a, b) -> a < b)
	413
	414	let test_tup3 =
	415	Test.make
	416	~name:"forall (a, b, c) in nat: a < b < c"
	417	(tup3 small_int small_int small_int)
	418	(fun (a, b, c) -> a < b && b < c)
	419
	420	let test_tup4 =
	421	Test.make
	422	~name:"forall (a, b, c, d) in nat: a < b < c < d"
	423	(tup4 small_int small_int small_int small_int)
	424	(fun (a, b, c, d) -> a < b && b < c && c < d)
	425
	426	let test_tup5 =
	427	Test.make
	428	~name:"forall (a, b, c, d, e) in nat: a < b < c < d < e"
	429	(tup5 small_int small_int small_int small_int small_int)
	430	(fun (a, b, c, d, e) -> a < b && b < c && c < d && d < e)
	431
	432	let test_tup6 =
	433	Test.make
	434	~name:"forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f"
	435	(tup6 small_int small_int small_int small_int small_int small_int)
	436	(fun (a, b, c, d, e, f) -> a < b && b < c && c < d && d < e && e < f)
	437
	438	let test_tup7 =
	439	Test.make
	440	~name:"forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g"
	441	(tup7 small_int small_int small_int small_int small_int small_int small_int)
	442	(fun (a, b, c, d, e, f, g) -> a < b && b < c && c < d && d < e && e < f && f < g)
	443
	444	let test_tup8 =
	445	Test.make
	446	~name:"forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h"
	447	(tup8 small_int small_int small_int small_int small_int small_int small_int small_int)
	448	(fun (a, b, c, d, e, f, g, h) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h)
	449
	450	let test_tup9 =
	451	Test.make
	452	~name:"forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i"
	453	(tup9 small_int small_int small_int small_int small_int small_int small_int small_int small_int)
	454	(fun (a, b, c, d, e, f, g, h, i) -> a < b && b < c && c < d && d < e && e < f && f < g && g < h && h < i)
	455
	456	let tests = [
	457	(test_fac_issue59;)
	458	big_bound_issue59;
	459	long_shrink;
	460	ints_arent_0_mod_3;
	461	ints_are_0;
	462	ints_smaller_209609;
	463	nats_smaller_5001;
	464	char_is_never_abcdef;
	465	strings_are_empty;
	466	string_never_has_000_char;
	467	string_never_has_255_char;
	468	lists_are_empty_issue_64;
	469	list_shorter_10;
	470	list_shorter_432;
	471	list_shorter_4332;
	472	list_equal_dupl;
	473	list_unique_elems;
	474	test_tup2;
	475	test_tup3;
	476	test_tup4;
	477	test_tup5;
	478	test_tup6;
	479	test_tup7;
	480	test_tup8;
	481	test_tup9;
	482	]
313	483	end
314	484
315	485	(* tests function generator and shrinker *)

383	553	let f = Fn.apply f in
384	554	List.fold_left f acc (is @ js)
385	555	= List.fold_left f (List.fold_left f acc is) is) (Typo)
	556
	557	let tests = [
	558	fail_pred_map_commute;
	559	fail_pred_strings;
	560	prop_foldleft_foldright;
	561	prop_foldleft_foldright_uncurry;
	562	prop_foldleft_foldright_uncurry_funlast;
	563	fold_left_test;
	564	]
386	565	end
387	566
388	567	(* tests of (inner) find_example(_gen) behaviour *)

406	585	let find_ex_uncaught_issue_99_2_succeed =
407	586	Test.make ~name:"should_succeed_#99_2" ~count:10
408	587	int (fun i -> i <= max_int)
	588
	589	let tests = [
	590	find_ex;
	591	find_ex_uncaught_issue_99_1_fail;
	592	find_ex_uncaught_issue_99_2_succeed;
	593	]
409	594	end
410	595
411	596	(* tests of statistics and histogram display *)

474	659	Test.make ~name:"range_subset_spec" ~count:5_000
475	660	(add_stat ("dist", fun a -> a.(0)) (make (Gen.range_subset ~size:1 0 20)))
476	661	(fun a -> Array.length a = 1)
	662
	663	let tests =
	664	[
	665	bool_dist;
	666	char_dist;
	667	tree_depth_test;
	668	range_subset_test
	669	]
	670	@ string_len_tests
	671	@ list_len_tests
	672	@ array_len_tests
	673	@ int_dist_tests
477	674	end
478	675
479	676	(* Calling runners *)
480	677
481	678	let () = QCheck_base_runner.set_seed 1234
482	679	let _ =
483		QCheck_base_runner.run_tests ~colors:false ([
484		Overall.passing;
485		Overall.failing;
486		Overall.error;
487		Overall.collect;
488		Overall.stats;
489		Overall.bad_assume_warn;
490		Overall.bad_assume_fail;
491		Generator.char_dist_issue_23;
492		Generator.char_test;
493		Generator.nat_test;
494		Generator.string_test;
495		Generator.list_test;
496		Generator.list_repeat_test;
497		Generator.array_repeat_test;
498		Generator.passing_tree_rev;
499		Generator.nat_split2_spec;
500		Generator.pos_split2_spec;
501		Generator.range_subset_spec;
502		Generator.nat_split_n_way;
503		Generator.nat_split_smaller;
504		Generator.pos_split;
505		(Shrink.test_fac_issue59;)
506		Shrink.big_bound_issue59;
507		Shrink.long_shrink;
508		Shrink.ints_arent_0_mod_3;
509		Shrink.ints_are_0;
510		Shrink.ints_smaller_209609;
511		Shrink.nats_smaller_5001;
512		Shrink.char_is_never_abcdef;
513		Shrink.strings_are_empty;
514		Shrink.string_never_has_000_char;
515		Shrink.string_never_has_255_char;
516		Shrink.lists_are_empty_issue_64;
517		Shrink.list_shorter_10;
518		Shrink.list_shorter_432;
519		Shrink.list_shorter_4332;
520		Shrink.list_equal_dupl;
521		Shrink.list_unique_elems;
522		Function.fail_pred_map_commute;
523		Function.fail_pred_strings;
524		Function.prop_foldleft_foldright;
525		Function.prop_foldleft_foldright_uncurry;
526		Function.prop_foldleft_foldright_uncurry_funlast;
527		Function.fold_left_test;
528		FindExample.find_ex;
529		FindExample.find_ex_uncaught_issue_99_1_fail;
530		FindExample.find_ex_uncaught_issue_99_2_succeed;
531		Stats.bool_dist;
532		Stats.char_dist;
533		Stats.tree_depth_test;
534		Stats.range_subset_test]
535		@ Stats.string_len_tests
536		@ Stats.list_len_tests
537		@ Stats.array_len_tests
538		@ Stats.int_dist_tests)
	680	QCheck_base_runner.run_tests ~colors:false (
	681	Overall.tests @
	682	Generator.tests @
	683	Shrink.tests @
	684	Function.tests @
	685	FindExample.tests @
	686	Stats.tests)
539	687
540	688	let () = QCheck_base_runner.set_seed 153870556
541	689	let _ = QCheck_base_runner.run_tests ~colors:false [Stats.int_dist_empty_bucket]

+56

-2

test/core/qcheck2_output.txt.expected less more

0	0	random seed: 1234
1		2724675603984413065
	1	50 7 0 0 0 0 0 0 0 0 0 0 3 3 3 3 3 3 3 3 3 3 5 5 5 5 5 5 5 5 5 5 6 6 6 6 6 6 6 6 6 6 2724675603984413065
2	2	0
3	3	1362337801992206532
4	4	0

220	220	110..115: ####################################################### 9
221	221	116..121: ################## 3
222	222
	223	--- Failure --------------------------------------------------------------------
	224
	225	Test with shrinking retries failed (0 shrink steps):
	226
	227	7
	228
223	229	!!! Warning !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
224	230
225	231	Warning for test WARN_unlikely_precond:

344	350	Test tree contains only 42 failed (2 shrink steps):
345	351
346	352	Leaf 0
	353
	354	--- Failure --------------------------------------------------------------------
	355
	356	Test forall (a, b) in nat: a < b failed (6 shrink steps):
	357
	358	(0, 0)
	359
	360	--- Failure --------------------------------------------------------------------
	361
	362	Test forall (a, b, c) in nat: a < b < c failed (3 shrink steps):
	363
	364	(0, 0, 0)
	365
	366	--- Failure --------------------------------------------------------------------
	367
	368	Test forall (a, b, c, d) in nat: a < b < c < d failed (4 shrink steps):
	369
	370	(0, 0, 0, 0)
	371
	372	--- Failure --------------------------------------------------------------------
	373
	374	Test forall (a, b, c, d, e) in nat: a < b < c < d < e failed (5 shrink steps):
	375
	376	(0, 0, 0, 0, 0)
	377
	378	--- Failure --------------------------------------------------------------------
	379
	380	Test forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f failed (6 shrink steps):
	381
	382	(0, 0, 0, 0, 0, 0)
	383
	384	--- Failure --------------------------------------------------------------------
	385
	386	Test forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g failed (7 shrink steps):
	387
	388	(0, 0, 0, 0, 0, 0, 0)
	389
	390	--- Failure --------------------------------------------------------------------
	391
	392	Test forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h failed (8 shrink steps):
	393
	394	(0, 0, 0, 0, 0, 0, 0, 0)
	395
	396	--- Failure --------------------------------------------------------------------
	397
	398	Test forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i failed (9 shrink steps):
	399
	400	(0, 0, 0, 0, 0, 0, 0, 0, 0)
347	401
348	402	--- Failure --------------------------------------------------------------------
349	403

933	987	4150517416584649600.. 4611686018427387903: ################# 189
934	988	================================================================================
935	989	1 warning(s)
936		failure (27 tests failed, 1 tests errored, ran 67 tests)
	990	failure (36 tests failed, 1 tests errored, ran 84 tests)
937	991	random seed: 153870556
938	992
939	993	+++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

+56

-2

test/core/qcheck_output.txt.expected less more

0	0	random seed: 1234
1		2724675603984413065
	1	50 7 4 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 2724675603984413065
2	2	1362337801992206533
3	3	681168900996103267
4	4	340584450498051634

155	155	110..115: ####################################################### 9
156	156	116..121: ################## 3
157	157
	158	--- Failure --------------------------------------------------------------------
	159
	160	Test with shrinking retries failed (1 shrink steps):
	161
	162	4
	163
158	164	!!! Warning !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
159	165
160	166	Warning for test WARN_unlikely_precond:

273	279	Test lists have unique elems failed (7 shrink steps):
274	280
275	281	[7; 7]
	282
	283	--- Failure --------------------------------------------------------------------
	284
	285	Test forall (a, b) in nat: a < b failed (13 shrink steps):
	286
	287	(0, 0)
	288
	289	--- Failure --------------------------------------------------------------------
	290
	291	Test forall (a, b, c) in nat: a < b < c failed (15 shrink steps):
	292
	293	(0, 0, 0)
	294
	295	--- Failure --------------------------------------------------------------------
	296
	297	Test forall (a, b, c, d) in nat: a < b < c < d failed (23 shrink steps):
	298
	299	(0, 0, 0, 0)
	300
	301	--- Failure --------------------------------------------------------------------
	302
	303	Test forall (a, b, c, d, e) in nat: a < b < c < d < e failed (28 shrink steps):
	304
	305	(0, 0, 0, 0, 0)
	306
	307	--- Failure --------------------------------------------------------------------
	308
	309	Test forall (a, b, c, d, e, f) in nat: a < b < c < d < e < f failed (30 shrink steps):
	310
	311	(0, 0, 0, 0, 0, 0)
	312
	313	--- Failure --------------------------------------------------------------------
	314
	315	Test forall (a, b, c, d, e, f, g) in nat: a < b < c < d < e < f < g failed (31 shrink steps):
	316
	317	(0, 0, 0, 0, 0, 0, 0)
	318
	319	--- Failure --------------------------------------------------------------------
	320
	321	Test forall (a, b, c, d, e, f, g, h) in nat: a < b < c < d < e < f < g < h failed (35 shrink steps):
	322
	323	(0, 0, 0, 0, 0, 0, 0, 0)
	324
	325	--- Failure --------------------------------------------------------------------
	326
	327	Test forall (a, b, c, d, e, f, g, h, i) in nat: a < b < c < d < e < f < g < h < i failed (42 shrink steps):
	328
	329	(0, 0, 0, 0, 0, 0, 0, 0, 0)
276	330
277	331	--- Failure --------------------------------------------------------------------
278	332

888	942	4150517416584649600.. 4611686018427387903: ################# 189
889	943	================================================================================
890	944	1 warning(s)
891		failure (26 tests failed, 1 tests errored, ran 73 tests)
	945	failure (35 tests failed, 1 tests errored, ran 90 tests)
892	946	random seed: 153870556
893	947
894	948	+++ Stats for int_dist_empty_bucket ++++++++++++++++++++++++++++++++++++++++++++++++++++++++

+11

-0

test/ppx_deriving_qcheck/deriver/dune less more

	0	(tests
	1	(names
	2	test_textual
	3	test_primitives
	4	test_qualified_names
	5	test_recursive
	6	test_tuple
	7	test_variants
	8	test_record)
	9	(libraries qcheck-alcotest ppxlib ppx_deriving_qcheck qcheck)
	10	(preprocess (pps ppxlib.metaquot ppx_deriving_qcheck)))

+15

-0

test/ppx_deriving_qcheck/deriver/helpers.ml less more

	0	open QCheck
	1
	2	(** {1. Helpers} *)
	3
	4	let seed = [\| 42 \|]
	5
	6	let generate gen = Gen.generate ~n:20 ~rand:(Random.State.make seed) gen
	7
	8	(** [test_compare msg eq gen_ref gen_cand] will generate with the same seed
	9	[gen_ref] and [gen_cand], and test with Alcotest that both generators
	10	generates the same values. *)
	11	let test_compare ~msg ~eq gen_ref gen_candidate =
	12	let expected = generate gen_ref in
	13	let actual = generate gen_candidate in
	14	Alcotest.(check (list eq)) msg expected actual

+89

-0

test/ppx_deriving_qcheck/deriver/test_primitives.ml less more

	0	open QCheck
	1	open Helpers
	2
	3	(** {1. Test primitives derivation} *)
	4
	5	(** {2. Tests} *)
	6
	7	type int' = int [@@deriving qcheck]
	8
	9	let test_int () =
	10	test_compare ~msg:"Gen.int <=> deriving int" ~eq:Alcotest.int Gen.int gen_int'
	11
	12	type unit' = unit [@@deriving qcheck]
	13
	14	(* Pretty useless though, but, meh *)
	15	let test_unit () =
	16	test_compare ~msg:"Gen.unit <=> deriving unit" ~eq:Alcotest.unit Gen.unit gen_unit'
	17
	18	type string' = string [@@deriving qcheck]
	19
	20	let test_string () =
	21	test_compare ~msg:"Gen.string <=> deriving string" ~eq:Alcotest.string Gen.string gen_string'
	22
	23	type char' = char [@@deriving qcheck]
	24
	25	let test_char () =
	26	test_compare ~msg:"Gen.char <=> deriving char" ~eq:Alcotest.char Gen.char gen_char'
	27
	28	type bool' = bool [@@deriving qcheck]
	29
	30	let test_bool () =
	31	test_compare ~msg:"Gen.bool <=> deriving bool" ~eq:Alcotest.bool Gen.bool gen_bool'
	32
	33	type float' = float [@@deriving qcheck]
	34
	35	let test_float () =
	36	test_compare ~msg:"Gen.float <=> deriving float" ~eq:(Alcotest.float 0.) Gen.float gen_float'
	37
	38	type int32' = int32 [@@deriving qcheck]
	39
	40	let test_int32 () =
	41	test_compare ~msg:"Gen.int32 <=> deriving int32" ~eq:Alcotest.int32 Gen.ui32 gen_int32'
	42
	43	type int64' = int64 [@@deriving qcheck]
	44
	45	let test_int64 () =
	46	test_compare ~msg:"Gen.int64 <=> deriving int64" ~eq:Alcotest.int64 Gen.ui64 gen_int64'
	47
	48	type 'a option' = 'a option [@@deriving qcheck]
	49
	50	let test_option () =
	51	let zero = Gen.pure 0 in
	52	test_compare ~msg:"Gen.opt <=> deriving opt"
	53	~eq:Alcotest.(option int)
	54	(Gen.opt zero) (gen_option' zero)
	55
	56	type 'a array' = 'a array [@@deriving qcheck]
	57
	58	let test_array () =
	59	let zero = Gen.pure 0 in
	60	test_compare ~msg:"Gen.array <=> deriving array"
	61	~eq:Alcotest.(array int)
	62	(Gen.array zero) (gen_array' zero)
	63
	64	type 'a list' = 'a list [@@deriving qcheck]
	65
	66	let test_list () =
	67	let zero = Gen.pure 0 in
	68	test_compare ~msg:"Gen.list <=> deriving list"
	69	~eq:Alcotest.(list int)
	70	(Gen.list zero) (gen_list' zero)
	71
	72	(** {2. Execute tests} *)
	73
	74	let () = Alcotest.run "Test_Primitives"
	75	[("Primitives",
	76	Alcotest.[
	77	test_case "test_int" `Quick test_int;
	78	test_case "test_unit" `Quick test_unit;
	79	test_case "test_string" `Quick test_string;
	80	test_case "test_char" `Quick test_char;
	81	test_case "test_bool" `Quick test_bool;
	82	test_case "test_float" `Quick test_float;
	83	test_case "test_int32" `Quick test_int32;
	84	test_case "test_int64" `Quick test_int64;
	85	test_case "test_option" `Quick test_option;
	86	test_case "test_array" `Quick test_array;
	87	test_case "test_list" `Quick test_list;
	88	])]

+37

-0

test/ppx_deriving_qcheck/deriver/test_qualified_names.ml less more

	0	open QCheck
	1	open Helpers
	2
	3	module type S = sig
	4	type t = int
	5
	6	val gen : int QCheck.Gen.t
	7	end
	8
	9	module Q : S = struct
	10	type t = int [@@deriving qcheck]
	11	end
	12
	13	module F (X : S) = struct
	14	type t = X.t [@@deriving qcheck]
	15	end
	16
	17	module G = F (Q)
	18
	19	type t = Q.t [@@deriving qcheck]
	20
	21	type u = G.t [@@deriving qcheck]
	22
	23	let test_module () =
	24	test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int Gen.int gen
	25
	26	let test_functor () =
	27	test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int Gen.int gen_u
	28
	29	(** {2. Execute tests} *)
	30
	31	let () = Alcotest.run "Test_Qualified_names"
	32	[("Qualified names",
	33	Alcotest.[
	34	test_case "test_module" `Quick test_module;
	35	test_case "test_functor" `Quick test_functor
	36	])]

+65

-0

test/ppx_deriving_qcheck/deriver/test_record.ml less more

	0	open QCheck
	1	open Helpers
	2
	3	type env = {
	4	rec_types : string list;
	5	curr_types : string list;
	6	curr_type : string
	7	}
	8	[@@deriving qcheck]
	9
	10	let pp_env fmt {rec_types; curr_types; curr_type} =
	11	let open Format in
	12	fprintf fmt {\|{
	13	rec_types = [%a];
	14	curr_types = [%a];
	15	curr_type = [%s];
	16	}\|}
	17	(pp_print_list pp_print_string) rec_types
	18	(pp_print_list pp_print_string) curr_types
	19	curr_type
	20
	21	let eq_env = Alcotest.of_pp pp_env
	22
	23	let gen_env_ref =
	24	let open Gen in
	25	map3 (fun rec_types curr_types curr_type ->
	26	{ rec_types; curr_types; curr_type })
	27	(list string) (list string) string
	28
	29	let test_env () =
	30	test_compare ~msg:"gen_env ref <=> deriving env"
	31	~eq:eq_env gen_env_ref gen_env
	32
	33	type color = Color of { red : float; green : float; blue : float }
	34	[@@deriving qcheck]
	35
	36	let pp_color fmt (Color {red; green; blue}) =
	37	let open Format in
	38	fprintf fmt {\|Color {
	39	red = %a;
	40	green = %a;
	41	blue = %a;
	42	}\|}
	43	pp_print_float red
	44	pp_print_float green
	45	pp_print_float blue
	46
	47	let eq_color = Alcotest.of_pp pp_color
	48
	49	let gen_color_ref =
	50	let open Gen in
	51	map3 (fun red green blue -> Color {red; green; blue}) float float float
	52
	53	let test_color () =
	54	test_compare ~msg:"gen_color ref <=> deriving color"
	55	~eq:eq_color gen_color_ref gen_color
	56
	57	(** {2. Execute tests} *)
	58
	59	let () = Alcotest.run "Test_Record"
	60	[("Record",
	61	Alcotest.[
	62	test_case "test_env" `Quick test_env;
	63	test_case "test_color" `Quick test_color;
	64	])]

+80

-0

test/ppx_deriving_qcheck/deriver/test_recursive.ml less more

	0	open QCheck
	1	open Helpers
	2
	3	type 'a tree = Leaf \| Node of 'a * 'a tree * 'a tree
	4	[@@deriving qcheck]
	5
	6	let rec pp_tree pp fmt x =
	7	let open Format in
	8	match x with
	9	\| Leaf ->
	10	fprintf fmt "Leaf"
	11	\| Node (x, l, r) ->
	12	fprintf fmt "Node (%a, %a, %a)"
	13	pp x
	14	(pp_tree pp) l
	15	(pp_tree pp) r
	16
	17	let eq_tree pp = Alcotest.of_pp (pp_tree pp)
	18
	19	let gen_tree_ref gen =
	20	let open Gen in
	21	sized @@ fix (fun self ->
	22	function
	23	\| 0 -> pure Leaf
	24	\| n ->
	25	oneof [
	26	pure Leaf;
	27	map3 (fun x l r -> Node (x,l,r)) gen (self (n/2)) (self (n/2));
	28	])
	29
	30	let gen_tree_candidate = gen_tree
	31
	32	let test_tree_ref () =
	33	let gen = Gen.int in
	34	test_compare ~msg:"gen tree <=> derivation tree"
	35	~eq:(eq_tree Format.pp_print_int)
	36	(gen_tree_ref gen) (gen_tree gen)
	37
	38	let test_leaf =
	39	Test.make
	40	~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)"
	41	(make (gen_tree_sized Gen.int 0))
	42	(function
	43	\| Leaf -> true
	44	\| Node (_, Leaf, Leaf) -> true
	45	\| _ -> false)
	46	\|>
	47	QCheck_alcotest.to_alcotest
	48
	49	(* A slight error has been found here:
	50	If the type is named `list` then `'a list` will be derived with the
	51	QCheck generator `list` instead of the `gen_list_sized`.
	52
	53	This could lead to a design choice:
	54	- do we allow overriding primitive types?
	55	- do we prioritize `Env.curr_types` over primitive types?
	56	*)
	57	type 'a my_list = Cons of 'a * 'a my_list \| Nil
	58	[@@deriving qcheck]
	59
	60	let rec length = function
	61	\| Nil -> 0
	62	\| Cons (_, xs) -> 1 + length xs
	63
	64	let test_length =
	65	Test.make
	66	~name:"gen_list_sized n >>= fun l -> length l <= n"
	67	small_int
	68	(fun n ->
	69	let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in
	70	length l <= n)
	71	\|>
	72	QCheck_alcotest.to_alcotest
	73
	74	let () = Alcotest.run "Test_Recursive"
	75	[("Recursive",
	76	Alcotest.[
	77	test_case "test_tree_ref" `Quick test_tree_ref;
	78	test_leaf
	79	])]

+818

-0

test/ppx_deriving_qcheck/deriver/test_textual.ml less more

	0	(** Module test for ppx_deriving_qcheck *)
	1	open Ppxlib
	2
	3	(** Primitive types tests *)
	4	let loc = Location.none
	5
	6	let f = Ppx_deriving_qcheck.derive_gen ~loc
	7
	8	let f' xs = List.map f xs \|> List.concat
	9
	10	let extract stri =
	11	match stri.pstr_desc with Pstr_type (x, y) -> (x, y) \| _ -> assert false
	12
	13	let extract' xs = List.map extract xs
	14
	15	let check_eq ~expected ~actual name =
	16	let f = Ppxlib.Pprintast.string_of_structure in
	17	Alcotest.(check string) name (f expected) (f actual)
	18
	19	let test_int () =
	20	let expected = [ [%stri let gen = QCheck.Gen.int] ] in
	21
	22	let actual = f @@ extract [%stri type t = int] in
	23
	24	check_eq ~expected ~actual "deriving int"
	25
	26	let test_float () =
	27	let expected = [ [%stri let gen = QCheck.Gen.float] ] in
	28	let actual = f @@ extract [%stri type t = float] in
	29
	30	check_eq ~expected ~actual "deriving float"
	31
	32	let test_char () =
	33	let expected = [ [%stri let gen = QCheck.Gen.char] ] in
	34	let actual = f @@ extract [%stri type t = char] in
	35
	36	check_eq ~expected ~actual "deriving char"
	37
	38	let test_string () =
	39	let expected = [ [%stri let gen = QCheck.Gen.string] ] in
	40	let actual = f @@ extract [%stri type t = string] in
	41
	42	check_eq ~expected ~actual "deriving string"
	43
	44	let test_unit () =
	45	let expected = [ [%stri let gen = QCheck.Gen.unit] ] in
	46	let actual = f @@ extract [%stri type t = unit] in
	47
	48	check_eq ~expected ~actual "deriving unit"
	49
	50	let test_bool () =
	51	let expected = [ [%stri let gen = QCheck.Gen.bool] ] in
	52	let actual = f @@ extract [%stri type t = bool] in
	53
	54	check_eq ~expected ~actual "deriving bool"
	55
	56	let test_int32 () =
	57	let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
	58	let actual = f @@ extract [%stri type t = int32] in
	59
	60	check_eq ~expected ~actual "deriving int32"
	61
	62	let test_int32' () =
	63	let expected = [ [%stri let gen = QCheck.Gen.ui32] ] in
	64	let actual = f @@ extract [%stri type t = Int32.t] in
	65
	66	check_eq ~expected ~actual "deriving int32'"
	67
	68	let test_int64 () =
	69	let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
	70	let actual = f @@ extract [%stri type t = int64] in
	71
	72	check_eq ~expected ~actual "deriving int64"
	73
	74	let test_int64' () =
	75	let expected = [ [%stri let gen = QCheck.Gen.ui64] ] in
	76	let actual = f @@ extract [%stri type t = Int64.t] in
	77
	78	check_eq ~expected ~actual "deriving int64'"
	79
	80	(* let test_bytes () =
	81	* let expected =
	82	* [
	83	* [%stri
	84	* let gen =
	85	* QCheck.map
	86	* (fun n -> Bytes.create n)
	87	* QCheck.(0 -- Sys.max_string_length)];
	88	* ]
	89	* in
	90	* let actual = f @@ extract [%stri type t = Bytes.t ] in
	91	*
	92	* check_eq ~expected ~actual "deriving int64" *)
	93
	94	let test_tuple () =
	95	let actual =
	96	f'
	97	@@ extract'
	98	[
	99	[%stri type t = int * int];
	100	[%stri type t = int * int * int];
	101	[%stri type t = int * int * int * int];
	102	[%stri type t = int * int * int * int * int];
	103	[%stri type t = int * int * int * int * int * int];
	104	]
	105	in
	106	let expected =
	107	[
	108	[%stri
	109	let gen =
	110	QCheck.Gen.map
	111	(fun (gen0, gen1) -> (gen0, gen1))
	112	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int)];
	113	[%stri
	114	let gen =
	115	QCheck.Gen.map
	116	(fun (gen0, gen1, gen2) -> (gen0, gen1, gen2))
	117	(QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)];
	118	[%stri
	119	let gen =
	120	QCheck.Gen.map
	121	(fun (gen0, gen1, gen2, gen3) -> (gen0, gen1, gen2, gen3))
	122	(QCheck.Gen.quad
	123	QCheck.Gen.int
	124	QCheck.Gen.int
	125	QCheck.Gen.int
	126	QCheck.Gen.int)];
	127	[%stri
	128	let gen =
	129	QCheck.Gen.map
	130	(fun ((gen0, gen1), (gen2, gen3, gen4)) ->
	131	(gen0, gen1, gen2, gen3, gen4))
	132	(QCheck.Gen.pair
	133	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int)
	134	(QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int))];
	135	[%stri
	136	let gen =
	137	QCheck.Gen.map
	138	(fun ((gen0, gen1, gen2), (gen3, gen4, gen5)) ->
	139	(gen0, gen1, gen2, gen3, gen4, gen5))
	140	(QCheck.Gen.pair
	141	(QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int)
	142	(QCheck.Gen.triple QCheck.Gen.int QCheck.Gen.int QCheck.Gen.int))];
	143	]
	144	in
	145
	146	check_eq ~expected ~actual "deriving tuples"
	147
	148	let test_option () =
	149	let expected = [ [%stri let gen = QCheck.Gen.opt QCheck.Gen.int] ] in
	150	let actual = f' @@ extract' [ [%stri type t = int option] ] in
	151	check_eq ~expected ~actual "deriving option"
	152
	153	let test_array () =
	154	let expected = [ [%stri let gen = QCheck.Gen.array QCheck.Gen.int] ] in
	155	let actual = f' @@ extract' [ [%stri type t = int array] ] in
	156	check_eq ~expected ~actual "deriving option"
	157
	158	let test_list () =
	159	let expected = [ [%stri let gen = QCheck.Gen.list QCheck.Gen.string] ] in
	160
	161	let actual = f' @@ extract' [ [%stri type t = string list] ] in
	162	check_eq ~expected ~actual "deriving list"
	163
	164	let test_alpha () =
	165	let expected =
	166	[
	167	[%stri let gen gen_a = gen_a];
	168	[%stri let gen gen_a = QCheck.Gen.list gen_a];
	169	[%stri let gen gen_a = QCheck.Gen.map (fun gen0 -> A gen0) gen_a];
	170	[%stri
	171	let gen gen_a gen_b =
	172	QCheck.Gen.map
	173	(fun (gen0, gen1) -> A (gen0, gen1))
	174	(QCheck.Gen.pair gen_a gen_b)];
	175	[%stri
	176	let gen gen_left gen_right =
	177	QCheck.Gen.map
	178	(fun (gen0, gen1) -> (gen0, gen1))
	179	(QCheck.Gen.pair gen_left gen_right)];
	180	[%stri
	181	let gen_int_tree = gen_tree QCheck.Gen.int
	182	]
	183	]
	184	in
	185	let actual =
	186	f'
	187	@@ extract'
	188	[
	189	[%stri type 'a t = 'a];
	190	[%stri type 'a t = 'a list];
	191	[%stri type 'a t = A of 'a];
	192	[%stri type ('a, 'b) t = A of 'a * 'b];
	193	[%stri type ('left, 'right) t = 'left * 'right];
	194	[%stri type int_tree = int tree]
	195	]
	196	in
	197	check_eq ~expected ~actual "deriving alpha"
	198
	199	let test_equal () =
	200	let expected =
	201	[
	202	[%stri
	203	let gen =
	204	QCheck.Gen.frequency
	205	[
	206	(1, QCheck.Gen.pure A);
	207	(1, QCheck.Gen.pure B);
	208	(1, QCheck.Gen.pure C);
	209	]];
	210	[%stri
	211	let gen_t' =
	212	QCheck.Gen.frequency
	213	[
	214	(1, QCheck.Gen.pure A);
	215	(1, QCheck.Gen.pure B);
	216	(1, QCheck.Gen.pure C);
	217	]];
	218	]
	219	in
	220	let actual =
	221	f'
	222	@@ extract'
	223	[ [%stri type t = A \| B \| C]; [%stri type t' = t = A \| B \| C] ]
	224	in
	225	check_eq ~expected ~actual "deriving equal"
	226
	227	let test_dependencies () =
	228	let expected =
	229	[
	230	[%stri
	231	let gen =
	232	QCheck.Gen.frequency
	233	[
	234	(1, QCheck.Gen.map (fun gen0 -> Int gen0) SomeModule.gen);
	235	( 1,
	236	QCheck.Gen.map
	237	(fun gen0 -> Float gen0)
	238	SomeModule.SomeOtherModule.gen );
	239	]];
	240	[%stri let gen = gen_something];
	241	]
	242	in
	243	let actual =
	244	f'
	245	@@ extract'
	246	[
	247	[%stri
	248	type t =
	249	\| Int of SomeModule.t
	250	\| Float of SomeModule.SomeOtherModule.t];
	251	[%stri type t = (Something.t[@gen gen_something])];
	252	]
	253	in
	254
	255	check_eq ~expected ~actual "deriving dependencies"
	256
	257	let test_konstr () =
	258	let expected =
	259	[
	260	[%stri let gen = QCheck.Gen.map (fun gen0 -> A gen0) QCheck.Gen.int];
	261	[%stri
	262	let gen =
	263	QCheck.Gen.frequency
	264	[
	265	(1, QCheck.Gen.map (fun gen0 -> B gen0) QCheck.Gen.int);
	266	(1, QCheck.Gen.map (fun gen0 -> C gen0) QCheck.Gen.int);
	267	]];
	268	[%stri
	269	let gen =
	270	QCheck.Gen.frequency
	271	[
	272	(1, QCheck.Gen.map (fun gen0 -> X gen0) gen_t1);
	273	(1, QCheck.Gen.map (fun gen0 -> Y gen0) gen_t2);
	274	(1, QCheck.Gen.map (fun gen0 -> Z gen0) QCheck.Gen.string);
	275	]];
	276	[%stri
	277	let gen =
	278	QCheck.Gen.frequency
	279	[ (1, QCheck.Gen.pure Left); (1, QCheck.Gen.pure Right) ]];
	280	[%stri
	281	let gen =
	282	QCheck.Gen.frequency
	283	[
	284	(1, QCheck.Gen.map (fun gen0 -> Simple gen0) QCheck.Gen.int);
	285	( 1,
	286	QCheck.Gen.map
	287	(fun (gen0, gen1) -> Double (gen0, gen1))
	288	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int) );
	289	( 1,
	290	QCheck.Gen.map
	291	(fun (gen0, gen1, gen2) -> Triple (gen0, gen1, gen2))
	292	(QCheck.Gen.triple
	293	QCheck.Gen.int
	294	QCheck.Gen.int
	295	QCheck.Gen.int) );
	296	]];
	297	]
	298	in
	299	let actual =
	300	f'
	301	@@ extract'
	302	[
	303	[%stri type t = A of int];
	304	[%stri type t = B of int \| C of int];
	305	[%stri type t = X of t1 \| Y of t2 \| Z of string];
	306	[%stri type t = Left \| Right];
	307	[%stri
	308	type t =
	309	\| Simple of int
	310	\| Double of int * int
	311	\| Triple of int * int * int];
	312	]
	313	in
	314	check_eq ~expected ~actual "deriving constructors"
	315
	316	let test_record () =
	317	let expected =
	318	[
	319	[%stri
	320	let gen =
	321	QCheck.Gen.map
	322	(fun (gen0, gen1) -> { a = gen0; b = gen1 })
	323	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.string)];
	324	[%stri
	325	let gen =
	326	QCheck.Gen.map
	327	(fun (gen0, gen1) -> { a = gen0; b = gen1 })
	328	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.string)];
	329	[%stri
	330	let gen =
	331	QCheck.Gen.frequency
	332	[
	333	(1, QCheck.Gen.map (fun gen0 -> A gen0) gen_t');
	334	( 1,
	335	QCheck.Gen.map
	336	(fun (gen0, gen1) -> B { left = gen0; right = gen1 })
	337	(QCheck.Gen.pair QCheck.Gen.int QCheck.Gen.int) );
	338	]];
	339	]
	340	in
	341	let actual =
	342	f'
	343	@@ extract'
	344	[
	345	[%stri type t = { a : int; b : string }];
	346	[%stri type t = { mutable a : int; mutable b : string }];
	347	[%stri type t = A of t' \| B of { left : int; right : int }];
	348	]
	349	in
	350	check_eq ~expected ~actual "deriving record"
	351
	352	let test_variant () =
	353	let expected =
	354	[
	355	[%stri
	356	let gen =
	357	(QCheck.Gen.frequency
	358	[
	359	(1, QCheck.Gen.pure `A);
	360	(1, QCheck.Gen.map (fun gen0 -> `B gen0) QCheck.Gen.int);
	361	(1, QCheck.Gen.map (fun gen0 -> `C gen0) QCheck.Gen.string);
	362	]
	363	: t QCheck.Gen.t)];
	364	[%stri
	365	let gen_t' =
	366	(QCheck.Gen.frequency [ (1, QCheck.Gen.pure `B); (1, gen) ]
	367	: t' QCheck.Gen.t)];
	368	]
	369	in
	370	let actual =
	371	f'
	372	@@ extract'
	373	[
	374	[%stri type t = [ `A \| `B of int \| `C of string ]];
	375	[%stri type t' = [ `B \| t ]];
	376	]
	377	in
	378	check_eq ~expected ~actual "deriving variant"
	379
	380	let test_tree () =
	381	let expected =
	382	[
	383	[%stri
	384	let rec gen_tree_sized gen_a n =
	385	match n with
	386	\| 0 -> QCheck.Gen.pure Leaf
	387	\| _ ->
	388	QCheck.Gen.frequency
	389	[
	390	(1, QCheck.Gen.pure Leaf);
	391	( 1,
	392	QCheck.Gen.map
	393	(fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
	394	(QCheck.Gen.triple
	395	gen_a
	396	((gen_tree_sized gen_a) (n / 2))
	397	((gen_tree_sized gen_a) (n / 2))) );
	398	]
	399	];
	400	[%stri
	401	let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)
	402	];
	403	]
	404	in
	405	let actual =
	406	f
	407	@@ extract [%stri type 'a tree = Leaf \| Node of 'a * 'a tree * 'a tree];
	408	in
	409	check_eq ~expected ~actual "deriving tree"
	410
	411	let test_expr () =
	412	let expected =
	413	[
	414	[%stri
	415	let rec gen_expr_sized n =
	416	match n with
	417	\| 0 -> QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
	418	\| _ ->
	419	QCheck.Gen.frequency
	420	[
	421	( 1,
	422	QCheck.Gen.map (fun gen0 -> Value gen0) QCheck.Gen.int
	423	);
	424	( 1,
	425	QCheck.Gen.map
	426	(fun (gen0, gen1, gen2) -> If (gen0, gen1, gen2))
	427	(QCheck.Gen.triple
	428	(gen_expr_sized (n / 2))
	429	(gen_expr_sized (n / 2))
	430	(gen_expr_sized (n / 2))) );
	431	( 1,
	432	QCheck.Gen.map
	433	(fun (gen0, gen1) -> Eq (gen0, gen1))
	434	(QCheck.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
	435	( 1,
	436	QCheck.Gen.map
	437	(fun (gen0, gen1) -> Lt (gen0, gen1))
	438	(QCheck.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
	439	]
	440	];
	441	[%stri
	442	let gen_expr = QCheck.Gen.sized @@ gen_expr_sized
	443	]
	444	]
	445	in
	446	let actual =
	447	f @@ extract
	448	[%stri
	449	type expr =
	450	\| Value of int
	451	\| If of expr * expr * expr
	452	\| Eq of expr * expr
	453	\| Lt of expr * expr]
	454	in
	455	check_eq ~expected ~actual "deriving expr"
	456
	457	let test_forest () =
	458	let expected =
	459	[
	460	[%stri
	461	let rec gen_tree_sized gen_a n =
	462	QCheck.Gen.map
	463	(fun gen0 -> Node gen0)
	464	(QCheck.Gen.map
	465	(fun (gen0, gen1) -> (gen0, gen1))
	466	(QCheck.Gen.pair gen_a ((gen_forest_sized gen_a) (n / 2))))
	467
	468	and gen_forest_sized gen_a n =
	469	match n with
	470	\| 0 -> QCheck.Gen.pure Nil
	471	\| _ ->
	472	QCheck.Gen.frequency
	473	[
	474	(1, QCheck.Gen.pure Nil);
	475	( 1,
	476	QCheck.Gen.map
	477	(fun gen0 -> Cons gen0)
	478	(QCheck.Gen.map
	479	(fun (gen0, gen1) -> (gen0, gen1))
	480	(QCheck.Gen.pair
	481	((gen_tree_sized gen_a) (n / 2))
	482	((gen_forest_sized gen_a) (n / 2)))) );
	483	]
	484	];
	485	[%stri let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)];
	486	[%stri let gen_forest gen_a = QCheck.Gen.sized @@ (gen_forest_sized gen_a)];
	487	]
	488	in
	489	let actual =
	490	f
	491	@@ extract
	492	[%stri
	493	type 'a tree = Node of ('a * 'a forest)
	494
	495	and 'a forest = Nil \| Cons of ('a tree * 'a forest)]
	496	in
	497	check_eq ~expected ~actual "deriving forest"
	498
	499	let test_fun_primitives () =
	500	let expected =
	501	[
	502	[%stri
	503	let gen =
	504	QCheck.fun_nary
	505	QCheck.Tuple.(
	506	QCheck.Observable.int @-> QCheck.Observable.int @-> o_nil)
	507	(QCheck.make QCheck.Gen.string)
	508	\|> QCheck.gen];
	509	[%stri
	510	let gen =
	511	QCheck.fun_nary
	512	QCheck.Tuple.(
	513	QCheck.Observable.float @-> QCheck.Observable.float @-> o_nil)
	514	(QCheck.make QCheck.Gen.string)
	515	\|> QCheck.gen];
	516	[%stri
	517	let gen =
	518	QCheck.fun_nary
	519	QCheck.Tuple.(
	520	QCheck.Observable.string @-> QCheck.Observable.string @-> o_nil)
	521	(QCheck.make QCheck.Gen.string)
	522	\|> QCheck.gen];
	523	[%stri
	524	let gen =
	525	QCheck.fun_nary
	526	QCheck.Tuple.(
	527	QCheck.Observable.bool @-> QCheck.Observable.bool @-> o_nil)
	528	(QCheck.make QCheck.Gen.string)
	529	\|> QCheck.gen];
	530	[%stri
	531	let gen =
	532	QCheck.fun_nary
	533	QCheck.Tuple.(
	534	QCheck.Observable.char @-> QCheck.Observable.char @-> o_nil)
	535	(QCheck.make QCheck.Gen.string)
	536	\|> QCheck.gen];
	537	[%stri
	538	let gen =
	539	QCheck.fun_nary
	540	QCheck.Tuple.(QCheck.Observable.unit @-> o_nil)
	541	(QCheck.make QCheck.Gen.string)
	542	\|> QCheck.gen];
	543	]
	544	in
	545
	546	let actual =
	547	f'
	548	@@ extract'
	549	[
	550	[%stri type t = int -> int -> string];
	551	[%stri type t = float -> float -> string];
	552	[%stri type t = string -> string -> string];
	553	[%stri type t = bool -> bool -> string];
	554	[%stri type t = char -> char -> string];
	555	[%stri type t = unit -> string];
	556	]
	557	in
	558	check_eq ~expected ~actual "deriving fun primitives"
	559
	560	let test_fun_n () =
	561	let expected =
	562	[
	563	[%stri
	564	let gen =
	565	QCheck.fun_nary
	566	QCheck.Tuple.(
	567	QCheck.Observable.bool @-> QCheck.Observable.int
	568	@-> QCheck.Observable.float @-> QCheck.Observable.string
	569	@-> QCheck.Observable.char @-> o_nil)
	570	(QCheck.make QCheck.Gen.unit)
	571	\|> QCheck.gen];
	572	]
	573	in
	574	let actual =
	575	f @@ extract [%stri type t = bool -> int -> float -> string -> char -> unit]
	576	in
	577	check_eq ~expected ~actual "deriving fun n"
	578
	579	let test_fun_option () =
	580	let expected =
	581	[
	582	[%stri
	583	let gen =
	584	QCheck.fun_nary
	585	QCheck.Tuple.(
	586	QCheck.Observable.option QCheck.Observable.int @-> o_nil)
	587	(QCheck.make QCheck.Gen.unit)
	588	\|> QCheck.gen];
	589	]
	590	in
	591	let actual = f @@ extract [%stri type t = int option -> unit] in
	592	check_eq ~expected ~actual "deriving fun option"
	593
	594	let test_fun_list () =
	595	let expected =
	596	[
	597	[%stri
	598	let gen =
	599	QCheck.fun_nary
	600	QCheck.Tuple.(
	601	QCheck.Observable.list QCheck.Observable.int @-> o_nil)
	602	(QCheck.make QCheck.Gen.unit)
	603	\|> QCheck.gen];
	604	]
	605	in
	606	let actual = f @@ extract [%stri type t = int list -> unit] in
	607	check_eq ~expected ~actual "deriving fun list"
	608
	609	let test_fun_array () =
	610	let expected =
	611	[
	612	[%stri
	613	let gen =
	614	QCheck.fun_nary
	615	QCheck.Tuple.(
	616	QCheck.Observable.array QCheck.Observable.int @-> o_nil)
	617	(QCheck.make QCheck.Gen.unit)
	618	\|> QCheck.gen];
	619	]
	620	in
	621	let actual = f @@ extract [%stri type t = int array -> unit] in
	622	check_eq ~expected ~actual "deriving fun array"
	623
	624	let test_fun_tuple () =
	625	let expected =
	626	[
	627	[%stri
	628	let gen =
	629	QCheck.fun_nary
	630	QCheck.Tuple.(
	631	QCheck.Observable.pair QCheck.Observable.int QCheck.Observable.int
	632	@-> o_nil)
	633	(QCheck.make QCheck.Gen.unit)
	634	\|> QCheck.gen];
	635	[%stri
	636	let gen =
	637	QCheck.fun_nary
	638	QCheck.Tuple.(
	639	QCheck.Observable.triple
	640	QCheck.Observable.int
	641	QCheck.Observable.int
	642	QCheck.Observable.int
	643	@-> o_nil)
	644	(QCheck.make QCheck.Gen.unit)
	645	\|> QCheck.gen];
	646	[%stri
	647	let gen =
	648	QCheck.fun_nary
	649	QCheck.Tuple.(
	650	QCheck.Observable.quad
	651	QCheck.Observable.int
	652	QCheck.Observable.int
	653	QCheck.Observable.int
	654	QCheck.Observable.int
	655	@-> o_nil)
	656	(QCheck.make QCheck.Gen.unit)
	657	\|> QCheck.gen];
	658	]
	659	in
	660	let actual =
	661	f'
	662	@@ extract'
	663	[
	664	[%stri type t = int * int -> unit];
	665	[%stri type t = int * int * int -> unit];
	666	[%stri type t = int * int * int * int -> unit];
	667	]
	668	in
	669	check_eq ~expected ~actual "deriving fun tuple"
	670
	671	let test_weight_konstrs () =
	672	let expected =
	673	[
	674	[%stri
	675	let gen =
	676	QCheck.Gen.frequency
	677	[
	678	(5, QCheck.Gen.pure A);
	679	(6, QCheck.Gen.pure B);
	680	(1, QCheck.Gen.pure C);
	681	]];
	682	]
	683	in
	684	let actual =
	685	f @@ extract [%stri type t = A [@weight 5] \| B [@weight 6] \| C]
	686	in
	687	check_eq ~expected ~actual "deriving weight konstrs"
	688
	689	(* Regression test: https://github.com/c-cube/qcheck/issues/187 *)
	690	let test_recursive_poly_variant () =
	691	let expected =
	692	[
	693	[%stri
	694	let rec gen_tree_sized gen_a n =
	695	(match n with
	696	\| 0 -> QCheck.Gen.map (fun gen0 -> `Leaf gen0) gen_a
	697	\| _ ->
	698	QCheck.Gen.frequency
	699	[
	700	( 1,
	701	QCheck.Gen.map (fun gen0 -> `Leaf gen0) gen_a
	702	);
	703	( 1,
	704	QCheck.Gen.map
	705	(fun gen0 -> `Node gen0)
	706	(QCheck.Gen.map
	707	(fun (gen0, gen1) -> (gen0, gen1))
	708	(QCheck.Gen.pair
	709	((gen_tree_sized gen_a) (n / 2))
	710	((gen_tree_sized gen_a) (n / 2))))
	711	);
	712	]
	713	: tree QCheck.Gen.t)];
	714	[%stri
	715	let gen_tree gen_a = QCheck.Gen.sized @@ (gen_tree_sized gen_a)
	716	]
	717	]
	718	in
	719	let actual =
	720	f @@ extract [%stri type 'a tree = [ `Leaf of 'a \| `Node of 'a tree * 'a tree ]]
	721	in
	722	check_eq ~expected ~actual "deriving recursive polymorphic variants"
	723
	724	(* Regression test: https://github.com/c-cube/qcheck/issues/213 *)
	725	let test_unused_variable () =
	726	let expected =
	727	[
	728	[%stri
	729	let rec gen_c_sized n =
	730	match n with
	731	\| 0 -> QCheck.Gen.pure A
	732	\| _ ->
	733	QCheck.Gen.frequency
	734	[(1, (QCheck.Gen.pure A));
	735	(1, (QCheck.Gen.map (fun gen0 -> B gen0) gen_myint))]
	736	and gen_myint = QCheck.Gen.nat
	737	];
	738	[%stri
	739	let gen_c = QCheck.Gen.sized @@ gen_c_sized
	740	];
	741	[%stri
	742	let rec gen_c_sized _n =
	743	QCheck.Gen.frequency
	744	[(1, (QCheck.Gen.map (fun gen0 -> A gen0) gen_myint));
	745	(1, (QCheck.Gen.map (fun gen0 -> B gen0) gen_myint))]
	746	and gen_myint = QCheck.Gen.nat
	747	];
	748	[%stri
	749	let gen_c = QCheck.Gen.sized @@ gen_c_sized
	750	];
	751	]
	752	in
	753	let actual =
	754	f' @@ extract' [
	755	[%stri
	756	type c =
	757	\| A
	758	\| B of myint
	759	and myint = int [@gen QCheck.Gen.nat] ];
	760	[%stri
	761	type c =
	762	\| A of myint
	763	\| B of myint
	764	and myint = int [@gen QCheck.Gen.nat] ];
	765	]
	766	in
	767	check_eq ~expected ~actual "deriving variant with unused fuel parameter"
	768
	769
	770	let () =
	771	Alcotest.(
	772	run
	773	"ppx_deriving_qcheck tests"
	774	[
	775	( "deriving generator good",
	776	[
	777	test_case "deriving int" `Quick test_int;
	778	test_case "deriving float" `Quick test_float;
	779	test_case "deriving char" `Quick test_char;
	780	test_case "deriving string" `Quick test_string;
	781	test_case "deriving unit" `Quick test_unit;
	782	test_case "deriving bool" `Quick test_bool;
	783	test_case "deriving int32" `Quick test_int32;
	784	test_case "deriving int32'" `Quick test_int32';
	785	test_case "deriving int64" `Quick test_int64;
	786	test_case "deriving int64'" `Quick test_int64';
	787	(* test_case "deriving bytes" `Quick test_bytes; *)
	788	test_case "deriving tuple" `Quick test_tuple;
	789	test_case "deriving option" `Quick test_option;
	790	test_case "deriving array" `Quick test_array;
	791	test_case "deriving list" `Quick test_list;
	792	test_case "deriving constructors" `Quick test_konstr;
	793	test_case "deriving dependencies" `Quick test_dependencies;
	794	test_case "deriving record" `Quick test_record;
	795	test_case "deriving equal" `Quick test_equal;
	796	test_case "deriving tree like" `Quick test_tree;
	797	test_case "deriving expr like" `Quick test_expr;
	798	test_case "deriving alpha" `Quick test_alpha;
	799	test_case "deriving variant" `Quick test_variant;
	800	test_case "deriving weight constructors" `Quick test_weight_konstrs;
	801	test_case "deriving forest" `Quick test_forest;
	802	test_case "deriving fun primitives" `Quick test_fun_primitives;
	803	test_case "deriving fun option" `Quick test_fun_option;
	804	test_case "deriving fun array" `Quick test_fun_array;
	805	test_case "deriving fun list" `Quick test_fun_list;
	806	test_case "deriving fun n" `Quick test_fun_n;
	807	test_case "deriving fun tuple" `Quick test_fun_tuple;
	808	test_case
	809	"deriving rec poly variants"
	810	`Quick
	811	test_recursive_poly_variant;
	812	test_case
	813	"deriving variant with unused fuel parameter"
	814	`Quick
	815	test_unused_variable;
	816	] );
	817	])

+106

-0

test/ppx_deriving_qcheck/deriver/test_tuple.ml less more

	0	open QCheck
	1
	2	type a = char [@gen QCheck.Gen.pure 'a']
	3	[@@deriving qcheck]
	4
	5	type b = char [@gen QCheck.Gen.pure 'b']
	6	[@@deriving qcheck]
	7
	8	type c = char [@gen QCheck.Gen.pure 'c']
	9	[@@deriving qcheck]
	10
	11	type d = char [@gen QCheck.Gen.pure 'd']
	12	[@@deriving qcheck]
	13
	14	type e = char [@gen QCheck.Gen.pure 'e']
	15	[@@deriving qcheck]
	16
	17	type f = char [@gen QCheck.Gen.pure 'f']
	18	[@@deriving qcheck]
	19
	20	type g = char [@gen QCheck.Gen.pure 'g']
	21	[@@deriving qcheck]
	22
	23	type h = char [@gen QCheck.Gen.pure 'h']
	24	[@@deriving qcheck]
	25
	26	type i = char [@gen QCheck.Gen.pure 'i']
	27	[@@deriving qcheck]
	28
	29	type tup2 = a * b
	30	[@@deriving qcheck]
	31
	32	type tup3 = a * b * c
	33	[@@deriving qcheck]
	34
	35	type tup4 = a * b * c * d
	36	[@@deriving qcheck]
	37
	38	type tup5 = a * b * c * d * e
	39	[@@deriving qcheck]
	40
	41	type tup6 = a * b * c * d * e * f
	42	[@@deriving qcheck]
	43
	44	type tup7 = a * b * c * d * e * f * g
	45	[@@deriving qcheck]
	46
	47	type tup8 = a * b * c * d * e * f * g * h
	48	[@@deriving qcheck]
	49
	50	let test_tup2 =
	51	Test.make ~count:10
	52	~name:"forall x in ('a', 'b'): x = ('a', 'b')"
	53	(make gen_tup2)
	54	(fun x -> x = ('a', 'b'))
	55
	56	let test_tup3 =
	57	Test.make ~count:10
	58	~name:"forall x in ('a', 'b', 'c'): x = ('a', 'b', 'c')"
	59	(make gen_tup3)
	60	(fun x -> x = ('a', 'b', 'c'))
	61
	62	let test_tup4 =
	63	Test.make ~count:10
	64	~name:"forall x in ('a', 'b', 'c', 'd'): x = ('a', 'b', 'c', 'd')"
	65	(make gen_tup4)
	66	(fun x -> x = ('a', 'b', 'c', 'd'))
	67
	68	let test_tup5 =
	69	Test.make ~count:10
	70	~name:"forall x in ('a', 'b', 'c', 'd', 'e'): x = ('a', 'b', 'c', 'd', 'e')"
	71	(make gen_tup5)
	72	(fun x -> x = ('a', 'b', 'c', 'd', 'e'))
	73
	74	let test_tup6 =
	75	Test.make ~count:10
	76	~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f'): x = ('a', 'b', 'c', 'd', 'e', 'f')"
	77	(make gen_tup6)
	78	(fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f'))
	79
	80	let test_tup7 =
	81	Test.make ~count:10
	82	~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f', 'g'): x = ('a', 'b', 'c', 'd', 'e', 'f', 'g')"
	83	(make gen_tup7)
	84	(fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f', 'g'))
	85
	86	let test_tup8 =
	87	Test.make ~count:10
	88	~name:"forall x in ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h'): x = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h')"
	89	(make gen_tup8)
	90	(fun x -> x = ('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h'))
	91
	92	let tests = [
	93	test_tup2;
	94	test_tup3;
	95	test_tup4;
	96	test_tup5;
	97	test_tup6;
	98	test_tup7;
	99	test_tup8;
	100	]
	101
	102	let tests = List.map (QCheck_alcotest.to_alcotest) tests
	103
	104	(** {2. Execute tests} *)
	105	let () = Alcotest.run "Test_Tuple" [("Tuple", tests)]

+81

-0

test/ppx_deriving_qcheck/deriver/test_variants.ml less more

	0	open QCheck
	1	open Helpers
	2
	3	(** {1. Test variants and polymorphic variants derivation} *)
	4
	5	(** {2. Variants} *)
	6
	7	type colors = Red \| Green \| Blue [@@deriving qcheck]
	8
	9	let pp_colors fmt x =
	10	let open Format in
	11	match x with
	12	\| Red -> fprintf fmt "Red"
	13	\| Green -> fprintf fmt "Green"
	14	\| Blue -> fprintf fmt "Blue"
	15
	16	let eq_colors = Alcotest.of_pp pp_colors
	17
	18	let gen = Gen.oneofl [Red; Green; Blue]
	19
	20	let test_variants () =
	21	test_compare ~msg:"Gen.oneofl <=> deriving variants" ~eq:eq_colors gen gen_colors
	22
	23	type poly_colors = [`Red \| `Green \| `Blue] [@@deriving qcheck]
	24
	25	let pp_poly_colors fmt x =
	26	let open Format in
	27	match x with
	28	\| `Red -> fprintf fmt "`Red"
	29	\| `Green -> fprintf fmt "`Green"
	30	\| `Blue -> fprintf fmt "`Blue"
	31
	32	let eq_poly_colors = Alcotest.of_pp pp_poly_colors
	33
	34	let gen_poly : poly_colors Gen.t = Gen.oneofl [`Red; `Green; `Blue]
	35
	36	let test_poly_variants () =
	37	test_compare ~msg:"Gen.oneofl <=> deriving variants"
	38	~eq:eq_poly_colors gen_poly gen_poly_colors
	39
	40	(** {2. Tests weight} *)
	41
	42	type letters =
	43	\| A [@weight 0]
	44	\| B
	45	[@@deriving qcheck]
	46
	47	let test_weight =
	48	Test.make ~name:"gen_letters always produces B"
	49	(make gen_letters)
	50	(function
	51	\| A -> false
	52	\| B -> true)
	53	\|>
	54	QCheck_alcotest.to_alcotest
	55
	56	type poly_letters = [
	57	\| `A [@weight 0]
	58	\| `B
	59	]
	60	[@@deriving qcheck]
	61
	62	let test_weight_poly =
	63	Test.make ~name:"gen_poly_letters always produces B"
	64	(make gen_poly_letters)
	65	(function
	66	\| `A -> false
	67	\| `B -> true)
	68	\|>
	69	QCheck_alcotest.to_alcotest
	70
	71	(** {2. Execute tests} *)
	72
	73	let () = Alcotest.run "Test_Variant"
	74	[("Variants",
	75	Alcotest.[
	76	test_case "test_variants" `Quick test_variants;
	77	test_case "test_poly_variants" `Quick test_poly_variants;
	78	test_weight;
	79	test_weight_poly
	80	])]