Commit ea1430fc89d324281b998c30e0cd86c474392277 - ocaml-qcheck

New upstream snapshot. Debian Janitor 1 year, 3 months ago

63 changed file(s) with 3770 addition(s) and 1569 deletion(s). Raw diff Collapse all Expand all

-43

~~.github/workflows/gh-pages.yml~~ less more

0		name: github pages
1
2		on:
3		push:
4		branches:
5		- master # Set a branch name to trigger deployment
6
7		jobs:
8		deploy:
9		runs-on: ubuntu-latest
10		steps:
11		- uses: actions/checkout@main
12
13		- name: Cache opam
14		id: cache-opam
15		uses: actions/cache@v2
16		with:
17		path: ~/.opam
18		key: opam-ubuntu-latest-4.12.0
19
20		- uses: avsm/setup-ocaml@v1
21		with:
22		ocaml-version: '4.12.0'
23
24		- name: Pin
25		run: opam pin -n .
26
27		- name: Depext
28		run: opam depext -yt qcheck-ounit qcheck-core qcheck
29
30		- name: Deps
31		run: opam install -d . --deps-only
32
33		- name: Build
34		run: opam exec -- dune build @doc
35
36		- name: Deploy
37		uses: peaceiris/actions-gh-pages@v3
38		with:
39		github_token: ${{ secrets.GITHUB_TOKEN }}
40		publish_dir: ./_build/default/_doc/_html/
41		destination_dir: dev
42		enable_jekyll: true

-32

~~.github/workflows/main.yml~~ less more

0		name: build
1		on:
2		push:
3		branches:
4		- master
5		pull_request:
6		branches:
7		- master
8		jobs:
9		run:
10		name: Build
11		strategy:
12		matrix:
13		os:
14		- macos-latest
15		- ubuntu-latest
16		- windows-latest
17		ocaml-compiler:
18		- 4.08.x
19		- 4.12.x
20		runs-on: ${{ matrix.os }}
21		steps:
22		- uses: actions/checkout@v2
23		- uses: ocaml/setup-ocaml@v2
24		with:
25		ocaml-compiler: ${{ matrix.ocaml-compiler }}
26		- run: opam pin -n .
27		- run: opam depext -yt qcheck qcheck-core qcheck-ounit qcheck-alcotest
28		- run: opam install -t . --deps-only
29		- run: opam exec -- dune build
30		- run: opam exec -- dune runtest
31		if: ${{ matrix.os == 'ubuntu-latest'}}

-13

~~.gitignore~~ less more

0		.*.swp
1		.*.swo
2		_build
3		*.native
4		.session
5		TAGS
6		*.docdir
7		man
8		*.install
9		*.tar.gz
10		*.byte
11		.merlin
12		_opam/

-3

~~.gitmodules~~ less more

0		[submodule "check-fun"]
1		path = check-fun
2		url = https://github.com/jmid/qcheck-fun

+14

-0

CHANGELOG.md less more

0	0	# Changes
1	1
	2	## NEXT RELEASE
	3
	4	- ...
	5
2	6	## 0.20
3	7
	8	- add several new `bytes` combinators:
	9	- `{QCheck,QCheck2}.Gen.{bytes_size,bytes,bytes_of,bytes_printable,bytes_small,bytes_small_of}`
	10	- `QCheck.{Print,Shrink,Observable}.bytes`
	11	- `QCheck2.{Print,Shrink}.bytes`
	12	- `QCheck.{bytes_gen_of_size,bytes_of,bytes,bytes_small,bytes_small_of,bytes_of_size,bytes_printable}`
	13	- add new `string` combinators and aliases:
	14	- `{QCheck,QCheck2}.Gen.{string_small,string_small_of}`
	15	- `QCheck.{string_small,string_small_of,string_of,string_printable,string_printable_of_size,string_small_printable,string_numeral,string_numeral_of_size}`
	16	- (`QCheck2.small_string` character generator argument is no more optional - reverted again due to backwards incompatibility)
4	17	- add an optional argument with conservative default to `Shrink.string`
5	18	- fix shrinkers in `QCheck.{printable_string,printable_string_of_size,small_printable_string,numeral_string,numeral_string_of_size}` [#257](https://github.com/c-cube/qcheck/issues/257)
6	19	- add `QCheck2.Gen.set_shrink` to modify the generator's shrinker
7	20	- add `QCheck2.Gen.no_shrink` to build a generator with no shrinking
8	21	- add an environment variable `QCHECK_MSG_INTERVAL` to control `QCheck_base_runner.time_between_msg`
	22	- fix unknown option error message referring to `qtest`
9	23
10	24	## 0.19.1
11	25

-2

debian/changelog less more

0		ocaml-qcheck (0.19.1+git20221027.1.98716de-1) UNRELEASED; urgency=low
	0	ocaml-qcheck (0.20+git20221107.1.063c1d7-1) UNRELEASED; urgency=low
1	1
2	2	* New upstream snapshot.
	3	* New upstream snapshot.
3	4
4		-- Debian Janitor <janitor@jelmer.uk> Fri, 28 Oct 2022 02:54:18 -0000
	5	-- Debian Janitor <janitor@jelmer.uk> Thu, 19 Jan 2023 04:12:17 -0000
5	6
6	7	ocaml-qcheck (0.18.1-2) unstable; urgency=medium
7	8

-2

example/alcotest/dune less more

0	0	(* -- tuareg -- *)
	1
	2	let suffix =
	3	try
	4	let major_version = List.hd (String.split_on_char '.' Sys.ocaml_version) in
	5	if int_of_string major_version < 5 then string_of_int Sys.word_size else "ocaml5"
	6	with _ -> failwith ("Unknown OCaml version format: " ^ Sys.ocaml_version)
1	7
2	8	let dune = Printf.sprintf {\|
3	9

22	28	(alias runtest)
23	29	(package qcheck-alcotest)
24	30	(enabled_if (= %%{os_type} "Unix"))
25		(action (diff output.txt.expected.%i output.txt)))
	31	(action (diff output.txt.expected.%s output.txt)))
26	32
27		\|} Sys.word_size
	33	\|} suffix
28	34
29	35	let () = Jbuild_plugin.V1.send dune

+83

-0

example/alcotest/output.txt.expected.ocaml5 less more

	0	qcheck random seed: 1234
	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	[OK] suite 3 neg test pass (failing as expected).
	6	[FAIL] suite 4 neg test unexpected success.
	7	[FAIL] suite 5 neg fail with error.
	8	[FAIL] suite 6 fail_check_err_message.
	9	[OK] suite 7 tree_rev_is_involutive.
	10	[FAIL] shrinking 0 debug_shrink.
	11	┌──────────────────────────────────────────────────────────────────────────────┐
	12	│ [FAIL] suite 1 fail_sort_id. │
	13	└──────────────────────────────────────────────────────────────────────────────┘
	14	test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps)
	15	[exception] test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps)
	16	──────────────────────────────────────────────────────────────────────────────
	17	┌──────────────────────────────────────────────────────────────────────────────┐
	18	│ [FAIL] suite 2 error_raise_exn. │
	19	└──────────────────────────────────────────────────────────────────────────────┘
	20	test `error_raise_exn`
	21	raised exception `Error`
	22	on `0 (after 62 shrink steps)`
	23	[exception] test `error_raise_exn`
	24	raised exception `Error`
	25	on `0 (after 62 shrink steps)`
	26	──────────────────────────────────────────────────────────────────────────────
	27	┌──────────────────────────────────────────────────────────────────────────────┐
	28	│ [FAIL] suite 4 neg test unexpected success. │
	29	└──────────────────────────────────────────────────────────────────────────────┘
	30	negative test 'neg test unexpected success' succeeded unexpectedly
	31	ASSERT negative test 'neg test unexpected success' succeeded unexpectedly
	32	FAIL negative test 'neg test unexpected success' succeeded unexpectedly
	33	──────────────────────────────────────────────────────────────────────────────
	34	┌──────────────────────────────────────────────────────────────────────────────┐
	35	│ [FAIL] suite 5 neg fail with error. │
	36	└──────────────────────────────────────────────────────────────────────────────┘
	37	test `neg fail with error`
	38	raised exception `Error`
	39	on `0 (after 7 shrink steps)`
	40	[exception] test `neg fail with error`
	41	raised exception `Error`
	42	on `0 (after 7 shrink steps)`
	43	──────────────────────────────────────────────────────────────────────────────
	44	┌──────────────────────────────────────────────────────────────────────────────┐
	45	│ [FAIL] suite 6 fail_check_err_message. │
	46	└──────────────────────────────────────────────────────────────────────────────┘
	47	test `fail_check_err_message` failed on ≥ 1 cases:
	48	0 (after 7 shrink steps)
	49	this
	50	will
	51	always
	52	fail
	53	[exception] test `fail_check_err_message` failed on ≥ 1 cases:
	54	0 (after 7 shrink steps)
	55	this
	56	will
	57	always
	58	fail
	59	──────────────────────────────────────────────────────────────────────────────
	60	┌──────────────────────────────────────────────────────────────────────────────┐
	61	│ [FAIL] shrinking 0 debug_shrink. │
	62	└──────────────────────────────────────────────────────────────────────────────┘
	63	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	64	Test debug_shrink successfully shrunk counter example (step 0) to:
	65	(2, 3)
	66	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	67	Test debug_shrink successfully shrunk counter example (step 1) to:
	68	(1, 3)
	69	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	70	Test debug_shrink successfully shrunk counter example (step 2) to:
	71	(0, 3)
	72	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	73	Test debug_shrink successfully shrunk counter example (step 3) to:
	74	(0, 2)
	75	~~~ Shrink ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	76	Test debug_shrink successfully shrunk counter example (step 4) to:
	77	(0, 1)
	78	law debug_shrink: 1 relevant cases (1 total)
	79	test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps)
	80	[exception] test `debug_shrink` failed on ≥ 1 cases: (0, 1) (after 4 shrink steps)
	81	──────────────────────────────────────────────────────────────────────────────
	82	6 failures! 9 tests run.

-2

example/dune less more

0	0	(* -- tuareg -- *)
	1
	2	let suffix =
	3	try
	4	let major_version = List.hd (String.split_on_char '.' Sys.ocaml_version) in
	5	if int_of_string major_version < 5 then string_of_int Sys.word_size else "ocaml5"
	6	with _ -> failwith ("Unknown OCaml version format: " ^ Sys.ocaml_version)
1	7
2	8	let dune = Printf.sprintf {\|
3	9

20	26	(alias runtest)
21	27	(enabled_if (= %%{os_type} "Unix"))
22	28	(package qcheck)
23		(action (diff output.txt.expected.%i output.txt)))
	29	(action (diff output.txt.expected.%s output.txt)))
24	30
25		\|} Sys.word_size
	31	\|} suffix
26	32
27	33	let () = Jbuild_plugin.V1.send dune

-2

example/ounit/dune less more

0	0	(* -- tuareg -- *)
	1
	2	let suffix =
	3	try
	4	let major_version = List.hd (String.split_on_char '.' Sys.ocaml_version) in
	5	if int_of_string major_version < 5 then string_of_int Sys.word_size else "ocaml5"
	6	with _ -> failwith ("Unknown OCaml version format: " ^ Sys.ocaml_version)
1	7
2	8	let dune = Printf.sprintf {\|
3	9

20	26	(alias runtest)
21	27	(package qcheck-ounit)
22	28	(enabled_if (= %%{os_type} "Unix"))
23		(action (diff output.txt.expected.%i output.txt)))
	29	(action (diff output.txt.expected.%s output.txt)))
24	30
25		\|} Sys.word_size
	31	\|} suffix
26	32
27	33	let () = Jbuild_plugin.V1.send dune

+65

-0

example/ounit/output.txt.expected.ocaml5 less more

	0	.FE.FEF.
	1	==============================================================================
	2	Error: tests:5:neg fail with error.
	3
	4	Error: tests:5:neg fail with error (in the log).
	5
	6
	7	test `neg fail with error`
	8	raised exception `Dune__exe__QCheck_ounit_test.Error`
	9	on `0 (after 7 shrink steps)`
	10
	11	------------------------------------------------------------------------------
	12	==============================================================================
	13	Error: tests:2:error_raise_exn.
	14
	15	Error: tests:2:error_raise_exn (in the log).
	16
	17
	18	test `error_raise_exn` raised exception `Dune__exe__QCheck_ounit_test.Error`
	19	on `0 (after 62 shrink steps)`
	20
	21	------------------------------------------------------------------------------
	22	==============================================================================
	23	Error: tests:6:fail_check_err_message.
	24
	25	Error: tests:6:fail_check_err_message (in the log).
	26
	27	Error: tests:6:fail_check_err_message (in the code).
	28
	29
	30	test `fail_check_err_message` failed on ≥ 1 cases:
	31	0 (after 7 shrink steps)
	32	this
	33	will
	34	always
	35	fail
	36
	37
	38
	39	------------------------------------------------------------------------------
	40	==============================================================================
	41	Error: tests:4:neg test unexpected success.
	42
	43	Error: tests:4:neg test unexpected success (in the log).
	44
	45	Error: tests:4:neg test unexpected success (in the code).
	46
	47
	48	negative test 'neg test unexpected success' succeeded unexpectedly
	49
	50	------------------------------------------------------------------------------
	51	==============================================================================
	52	Error: tests:1:fail_sort_id.
	53
	54	Error: tests:1:fail_sort_id (in the log).
	55
	56	Error: tests:1:fail_sort_id (in the code).
	57
	58
	59	test `fail_sort_id` failed on ≥ 1 cases: [1; 0] (after 16 shrink steps)
	60
	61
	62	------------------------------------------------------------------------------
	63	Ran: 8 tests in: <nondet> seconds.
	64	FAILED: Cases: 8 Tried: 8 Errors: 2 Failures: 3 Skip: 0 Todo: 0 Timeouts: 0.

+333

-0

example/output.txt.expected.ocaml5 less more

	0	random seed: 1234
	1
	2	--- Failure --------------------------------------------------------------------
	3
	4	Test should_fail_sort_id failed (10 shrink steps):
	5
	6	[1; 0]
	7
	8	=== Error ======================================================================
	9
	10	Test should_error_raise_exn errored on (62 shrink steps):
	11
	12	0
	13
	14	exception Dune__exe__QCheck_runner_test.Error
	15
	16
	17	+++ Collect ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	18
	19	Collect results for test collect_results:
	20
	21	4: 24 cases
	22	3: 20 cases
	23	2: 18 cases
	24	1: 21 cases
	25	0: 17 cases
	26
	27	+++ Stats for with_stats ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	28
	29	stats mod4:
	30	num: 100, avg: 1.56, stddev: 1.18, median 2, min 0, max 3
	31	0: ################################################# 27
	32	1: #################################### 20
	33	2: ########################################## 23
	34	3: ####################################################### 30
	35
	36	stats num:
	37	num: 100, avg: 62.24, stddev: 33.15, median 62, min 2, max 120
	38	2.. 7: ######### 2
	39	8.. 13: ################################ 7
	40	14.. 19: ########################### 6
	41	20.. 25: ############# 3
	42	26.. 31: ###################### 5
	43	32.. 37: ################## 4
	44	38.. 43: ############# 3
	45	44.. 49: ################################ 7
	46	50.. 55: ################################ 7
	47	56.. 61: ###################### 5
	48	62.. 67: #################################### 8
	49	68.. 73: ######### 2
	50	74.. 79: ###################### 5
	51	80.. 85: ######### 2
	52	86.. 91: ####################################################### 12
	53	92.. 97: ###################### 5
	54	98..103: ################## 4
	55	104..109: ################## 4
	56	110..115: ############# 3
	57	116..121: ########################### 6
	58
	59	--- Failure --------------------------------------------------------------------
	60
	61	Test neg test unexpected success failed:
	62
	63	Negative test neg test unexpected success succeeded but was expected to fail
	64
	65	=== Error ======================================================================
	66
	67	Test neg fail with error errored on (7 shrink steps):
	68
	69	0
	70
	71	exception Dune__exe__QCheck_runner_test.Error
	72
	73
	74	--- Failure --------------------------------------------------------------------
	75
	76	Test FAIL_pred_map_commute failed (79 shrink steps):
	77
	78	([11], {_ -> 0}, {11 -> false; _ -> true})
	79
	80	--- Failure --------------------------------------------------------------------
	81
	82	Test FAIL_fun2_pred_strings failed (1 shrink steps):
	83
	84	{some other string -> false; _ -> true}
	85
	86	--- Failure --------------------------------------------------------------------
	87
	88	Test fold_left fold_right failed (21 shrink steps):
	89
	90	(0, [1], {(0, 1) -> 1; _ -> 0})
	91
	92	+++ Messages ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	93
	94	Messages for test fold_left fold_right:
	95
	96	l=[1], fold_left=0, fold_right=1
	97
	98
	99	--- Failure --------------------------------------------------------------------
	100
	101	Test fold_left fold_right uncurried failed (41 shrink steps):
	102
	103	({(0, 4) -> 1; _ -> 0}, 0, [4])
	104
	105	--- Failure --------------------------------------------------------------------
	106
	107	Test long_shrink failed (149 shrink steps):
	108
	109	([0], [1])
	110
	111	--- Failure --------------------------------------------------------------------
	112
	113	Test mod3_should_fail failed (75 shrink steps):
	114
	115	4161
	116
	117	+++ Stats for stats_neg ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	118
	119	stats dist:
	120	num: 5000, avg: 0.43, stddev: 28.63, median 0, min -99, max 99
	121	-99..-90: # 45
	122	-89..-80: # 57
	123	-79..-70: # 68
	124	-69..-60: # 58
	125	-59..-50: # 76
	126	-49..-40: # 67
	127	-39..-30: # 52
	128	-29..-20: # 54
	129	-19..-10: # 47
	130	-9.. 0: ####################################################### 2205
	131	1.. 10: ########################################## 1697
	132	11.. 20: # 57
	133	21.. 30: # 70
	134	31.. 40: # 60
	135	41.. 50: # 66
	136	51.. 60: # 75
	137	61.. 70: # 68
	138	71.. 80: # 63
	139	81.. 90: # 66
	140	91..100: # 49
	141
	142	!!! Warning !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	143
	144	Warning for test WARN_unlikely_precond:
	145
	146	WARNING: only 0.8% tests (of 2000) passed precondition for "WARN_unlikely_precond"
	147
	148	NOTE: it is likely that the precondition is too strong, or that the generator is buggy.
	149
	150	--- Failure --------------------------------------------------------------------
	151
	152	Test FAIL_unlikely_precond failed:
	153
	154	ERROR: only 0.8% tests (of 2000) passed precondition for "FAIL_unlikely_precond"
	155
	156	NOTE: it is likely that the precondition is too strong, or that the generator is buggy.
	157
	158
	159	--- Failure --------------------------------------------------------------------
	160
	161	Test FAIL_#99_1 failed:
	162
	163	ERROR: uncaught exception in generator for test FAIL_#99_1 after 100 steps:
	164	Exception: QCheck.No_example_found("<example>")
	165	Backtrace:
	166
	167	+++ Stats for stat_display_test_1 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	168
	169	stats dist:
	170	num: 1000, avg: 0.86, stddev: 29.11, median 0, min -97, max 99
	171	-97..-88: # 12
	172	-87..-78: # 12
	173	-77..-68: # 13
	174	-67..-58: # 12
	175	-57..-48: # 9
	176	-47..-38: ## 17
	177	-37..-28: # 13
	178	-27..-18: # 8
	179	-17.. -8: ######### 76
	180	-7.. 2: ####################################################### 437
	181	3.. 12: ################################## 276
	182	13.. 22: ## 16
	183	23.. 32: # 11
	184	33.. 42: ## 16
	185	43.. 52: # 9
	186	53.. 62: # 12
	187	63.. 72: # 14
	188	73.. 82: # 12
	189	83.. 92: # 13
	190	93..102: # 12
	191
	192	+++ Stats for stat_display_test_2 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	193
	194	stats dist:
	195	num: 1000, avg: 15.86, stddev: 24.57, median 6, min 0, max 99
	196	0.. 4: ###################################################### 387
	197	5.. 9: ####################################################### 390
	198	10.. 14: # 11
	199	15.. 19: # 8
	200	20.. 24: # 11
	201	25.. 29: ## 15
	202	30.. 34: # 9
	203	35.. 39: # 11
	204	40.. 44: # 11
	205	45.. 49: ## 19
	206	50.. 54: # 10
	207	55.. 59: ## 19
	208	60.. 64: # 9
	209	65.. 69: # 9
	210	70.. 74: ## 19
	211	75.. 79: # 13
	212	80.. 84: # 11
	213	85.. 89: ## 16
	214	90.. 94: # 9
	215	95.. 99: # 13
	216
	217	+++ Stats for stat_display_test_3 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	218
	219	stats dist:
	220	num: 1000, avg: 193479.13, stddev: 136696.70, median 189823, min -43164, max 434961
	221	-43164..-19258: ################################### 42
	222	-19257.. 4649: ############################################## 56
	223	4650.. 28556: ############################################# 55
	224	28557.. 52463: ############################################### 57
	225	52464.. 76370: ######################################### 50
	226	76371..100277: ############################# 35
	227	100278..124184: ############################################### 57
	228	124185..148091: #################################### 44
	229	148092..171998: ############################################## 56
	230	171999..195905: ####################################################### 66
	231	195906..219812: ########################################### 52
	232	219813..243719: ######################################## 49
	233	243720..267626: ################################ 39
	234	267627..291533: ##################################### 45
	235	291534..315440: ##################################### 45
	236	315441..339347: ################################################# 59
	237	339348..363254: ################################################## 60
	238	363255..387161: ################################# 40
	239	387162..411068: ########################################## 51
	240	411069..434975: ################################### 42
	241
	242	+++ Stats for stat_display_test_4 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	243
	244	stats dist:
	245	num: 1000, avg: -591.06, stddev: 23026.79, median -911, min -39911, max 39959
	246	-39911..-35918: ####################################### 45
	247	-35917..-31924: #################################################### 59
	248	-31923..-27930: ########################################### 49
	249	-27929..-23936: ########################################## 48
	250	-23935..-19942: ####################################################### 62
	251	-19941..-15948: ############################################# 51
	252	-15947..-11954: ######################################### 47
	253	-11953.. -7960: ################################################# 56
	254	-7959.. -3966: ################################### 40
	255	-3965.. 28: ################################################### 58
	256	29.. 4022: ########################################### 49
	257	4023.. 8016: ############################################### 53
	258	8017.. 12010: ############################################ 50
	259	12011.. 16004: ################################### 40
	260	16005.. 19998: ####################################### 44
	261	19999.. 23992: ####################################################### 62
	262	23993.. 27986: ##################################### 42
	263	27987.. 31980: ######################################### 47
	264	31981.. 35974: ########################################## 48
	265	35975.. 39968: ############################################ 50
	266
	267	+++ Stats for stat_display_test_5 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	268
	269	stats dist:
	270	num: 1000, avg: -0.12, stddev: 2.52, median 0, min -4, max 4
	271	-4: ########################################## 116
	272	-3: ###################################### 103
	273	-2: ############################################## 125
	274	-1: ########################################## 115
	275	0: ####################################### 106
	276	1: ####################################################### 149
	277	2: ################################# 92
	278	3: ################################# 92
	279	4: ##################################### 102
	280
	281	+++ Stats for stat_display_test_6 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	282
	283	stats dist:
	284	num: 1000, avg: 6.42, stddev: 6.43, median 6, min -4, max 17
	285	-4..-3: ########################################### 89
	286	-2..-1: ################################################# 101
	287	0.. 1: ############################################## 95
	288	2.. 3: ########################################### 89
	289	4.. 5: ############################################## 95
	290	6.. 7: ##################################### 78
	291	8.. 9: ####################################### 81
	292	10..11: ######################################## 84
	293	12..13: ####################################################### 113
	294	14..15: ######################################## 84
	295	16..17: ############################################ 91
	296	18..19: 0
	297	20..21: 0
	298	22..23: 0
	299	24..25: 0
	300	26..27: 0
	301	28..29: 0
	302	30..31: 0
	303	32..33: 0
	304	34..35: 0
	305
	306	+++ Stats for stat_display_test_7 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
	307
	308	stats dist:
	309	num: 100000, avg: -7215552342607541.00, stddev: 2666234426234218496.00, median -16620417636667326, min -4611371852367564818, max 4611613630315464842
	310	-4611371852367564818..-4150222578233413331: ##################################################### 5003
	311	-4150222578233413330..-3689073304099261843: ####################################################### 5106
	312	-3689073304099261842..-3227924029965110355: ###################################################### 5052
	313	-3227924029965110354..-2766774755830958867: ###################################################### 5017
	314	-2766774755830958866..-2305625481696807379: #################################################### 4852
	315	-2305625481696807378..-1844476207562655891: ###################################################### 5016
	316	-1844476207562655890..-1383326933428504403: ###################################################### 5083
	317	-1383326933428504402.. -922177659294352915: ##################################################### 4986
	318	-922177659294352914.. -461028385160201427: ###################################################### 5042
	319	-461028385160201426.. 120888973950061: ###################################################### 5017
	320	120888973950062.. 461270163108101549: ##################################################### 4977
	321	461270163108101550.. 922419437242253037: ##################################################### 5000
	322	922419437242253038.. 1383568711376404525: ###################################################### 5022
	323	1383568711376404526.. 1844717985510556013: #################################################### 4896
	324	1844717985510556014.. 2305867259644707501: #################################################### 4884
	325	2305867259644707502.. 2767016533778858989: ##################################################### 4981
	326	2767016533778858990.. 3228165807913010477: ###################################################### 5026
	327	3228165807913010478.. 3689315082047161965: ###################################################### 5016
	328	3689315082047161966.. 4150464356181313453: ###################################################### 5021
	329	4150464356181313454.. 4611613630315464941: ##################################################### 5003
	330	================================================================================
	331	1 warning(s)
	332	failure (10 tests failed, 2 tests errored, ran 28 tests)

-1

ppx_deriving_qcheck.opam less more

0	0	opam-version: "2.0"
1	1	name: "ppx_deriving_qcheck"
2		version: "0.2.0"
	2	version: "0.3.0"
3	3	license: "BSD-2-Clause"
4	4	synopsis: "PPX Deriver for QCheck"
5	5

-2

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.19.1"
	7	version: "0.20"
8	8	tags: [
9	9	"test"
10	10	"quickcheck"

24	24	"alcotest" {>= "0.8.1"}
25	25	"odoc" {with-doc}
26	26	"ocaml" {>= "4.08.0"}
27		"ocaml" {with-test & < "5.0"}
28	27	]
29	28	dev-repo: "git+https://github.com/c-cube/qcheck.git"
30	29	bug-reports: "https://github.com/c-cube/qcheck/issues"

-2

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.19.1"
	7	version: "0.20"
8	8	tags: [
9	9	"test"
10	10	"property"

22	22	"alcotest" {with-test}
23	23	"odoc" {with-doc}
24	24	"ocaml" {>= "4.08.0"}
25		"ocaml" {with-test & < "5.0"}
26	25	]
27	26	dev-repo: "git+https://github.com/c-cube/qcheck.git"
28	27	bug-reports: "https://github.com/c-cube/qcheck/issues"

-2

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.19.1"
	7	version: "0.20"
8	8	tags: [
9	9	"qcheck"
10	10	"quickcheck"

23	23	"ounit2"
24	24	"odoc" {with-doc}
25	25	"ocaml" {>= "4.08.0"}
26		"ocaml" {with-test & < "5.0"}
27	26	]
28	27	dev-repo: "git+https://github.com/c-cube/qcheck.git"
29	28	bug-reports: "https://github.com/c-cube/qcheck/issues"

-2

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.19.1"
	7	version: "0.20"
8	8	tags: [
9	9	"test"
10	10	"property"

24	24	"alcotest" {with-test}
25	25	"odoc" {with-doc}
26	26	"ocaml" {>= "4.08.0"}
27		"ocaml" {with-test & < "5.0"}
28	27	]
29	28	dev-repo: "git+https://github.com/c-cube/qcheck.git"
30	29	bug-reports: "https://github.com/c-cube/qcheck/issues"

+46

-4

src/core/QCheck.ml less more

364	364	let printable st = printable_chars.[RS.int st (String.length printable_chars)]
365	365	let numeral st = char_of_int (48 + RS.int st 10)
366	366
367		let string_size ?(gen = char) size st =
	367	let bytes_size ?(gen = char) size st =
368	368	let s = Bytes.create (size st) in
369	369	for i = 0 to Bytes.length s - 1 do
370	370	Bytes.set s i (gen st)
371	371	done;
	372	s
	373
	374	let string_size ?(gen = char) size st =
	375	let s = bytes_size ~gen size st in
372	376	Bytes.unsafe_to_string s
	377
	378	let bytes ?gen st = bytes_size ?gen nat st
373	379	let string ?gen st = string_size ?gen nat st
	380	let bytes_of gen = bytes_size ~gen nat
374	381	let string_of gen = string_size ~gen nat
	382	let bytes_printable = bytes_size ~gen:printable nat
375	383	let string_printable = string_size ~gen:printable nat
376	384	let string_readable = string_printable
	385	let bytes_small st = bytes_size small_nat st
	386	let bytes_small_of gen st = bytes_size ~gen small_nat st
377	387	let small_string ?gen st = string_size ?gen small_nat st
378	388	let small_list gen = list_size small_nat gen
379	389	let small_array gen = array_size small_nat gen
	390	let string_small st = string_size small_nat st
	391	let string_small_of gen st = string_size ~gen small_nat st
380	392
381	393	let join g st = (g st) st
382	394

461	473	let int = string_of_int
462	474	let bool = string_of_bool
463	475	let float = string_of_float
	476	let bytes = Bytes.to_string
464	477	let string s = s
465	478	let char c = String.make 1 c
466	479

779	792	Buffer.clear buf;
780	793	yield s)
781	794
	795	let bytes ?(shrink = char) b = Iter.map Bytes.of_string (string ~shrink (Bytes.to_string b))
	796
782	797	let pair a b (x,y) yield =
783	798	a x (fun x' -> yield (x',y));
784	799	b y (fun y' -> yield (x,y'))

939	954	let int i = i land max_int
940	955	let bool b = if b then 1 else 2
941	956	let char x = Char.code x
	957	let bytes (x:bytes) = Hashtbl.hash x
942	958	let string (x:string) = Hashtbl.hash x
943	959	let opt f = function
944	960	\| None -> 42

952	968	type 'a t = 'a -> 'a -> bool
953	969
954	970	let int : int t = (=)
	971	let bytes : bytes t = (=)
955	972	let string : string t = (=)
956	973	let bool : bool t = (=)
957	974	let float = Float.equal

985	1002	let bool : bool t = make ~hash:H.bool ~eq:Eq.bool Print.bool
986	1003	let int : int t = make ~hash:H.int ~eq:Eq.int Print.int
987	1004	let float : float t = make ~eq:Eq.float Print.float
	1005	let bytes = make ~hash:H.bytes ~eq:Eq.bytes Print.bytes
988	1006	let string = make ~hash:H.string ~eq:Eq.string Print.string
989	1007	let char = make ~hash:H.char ~eq:Eq.char Print.char
990	1008

1108	1126	let numeral_char =
1109	1127	make ~print:(sprintf "%C") ~small:(small_char '0') ~shrink:Shrink.char_numeral Gen.numeral
1110	1128
	1129	let bytes_gen_of_size size gen =
	1130	make ~shrink:Shrink.bytes ~small:Bytes.length
	1131	~print:(Print.bytes) (Gen.bytes_size ~gen size)
	1132	let bytes_of gen =
	1133	make ~shrink:Shrink.bytes ~small:Bytes.length
	1134	~print:(Print.bytes) (Gen.bytes ~gen)
	1135
	1136	let bytes = bytes_of Gen.char
	1137	let bytes_of_size size = bytes_gen_of_size size Gen.char
	1138	let bytes_small = bytes_gen_of_size Gen.small_nat Gen.char
	1139	let bytes_small_of gen = bytes_gen_of_size Gen.small_nat gen
	1140	let bytes_printable =
	1141	make ~shrink:(Shrink.bytes ~shrink:Shrink.char_printable) ~small:Bytes.length
	1142	~print:(Print.bytes) (Gen.bytes ~gen:Gen.printable)
	1143
1111	1144	let string_gen_of_size size gen =
1112	1145	make ~shrink:Shrink.string ~small:String.length
1113	1146	~print:(sprintf "%S") (Gen.string_size ~gen size)
1114		let string_gen gen =
	1147	let string_of gen =
1115	1148	make ~shrink:Shrink.string ~small:String.length
1116	1149	~print:(sprintf "%S") (Gen.string ~gen)
1117	1150
1118		let string = string_gen Gen.char
	1151	let string = string_of Gen.char
1119	1152	let string_of_size size = string_gen_of_size size Gen.char
1120		let small_string = string_gen_of_size Gen.small_nat Gen.char
	1153	let string_small = string_gen_of_size Gen.small_nat Gen.char
	1154	let string_small_of gen = string_gen_of_size Gen.small_nat gen
	1155	let small_string = string_small
	1156	let string_gen = string_of
1121	1157
1122	1158	let printable_string =
1123	1159	make ~shrink:(Shrink.string ~shrink:Shrink.char_printable) ~small:String.length

1138	1174	let numeral_string_of_size size =
1139	1175	make ~shrink:(Shrink.string ~shrink:Shrink.char_numeral) ~small:String.length
1140	1176	~print:(sprintf "%S") (Gen.string_size ~gen:Gen.numeral size)
	1177
	1178	let string_printable = printable_string
	1179	let string_printable_of_size = printable_string_of_size
	1180	let string_small_printable = small_printable_string
	1181	let string_numeral = numeral_string
	1182	let string_numeral_of_size = numeral_string_of_size
1141	1183
1142	1184	let list_sum_ f l = List.fold_left (fun acc x-> f x+acc) 0 l
1143	1185

+107

-3

src/core/QCheck.mli less more

314	314	(** All corner cases for int.
315	315	@since 0.6 *)
316	316
317		val (--) : int -> int -> int t (** Synonym to {!int_range}. *)
	317	val (--) : int -> int -> int t (** Synonym for {!int_range}. *)
318	318
319	319	val ui32 : int32 t (** Generates (unsigned) [int32] values. *)
320	320

395	395	(** Generates chars between the two bounds, inclusive.
396	396	Example: [char_range 'a' 'z'] for all lower case ascii letters.
397	397	@since 0.13 *)
	398
	399	val bytes_size : ?gen:char t -> int t -> bytes t
	400	(** Builds a bytes generator from a (non-negative) size generator.
	401	Accepts an optional character generator (the default is {!char}).
	402	@since 0.20 *)
	403
	404	val bytes : ?gen:char t -> bytes t
	405	(** Builds a bytes generator. Bytes size is generated by {!nat}.
	406	Accepts an optional character generator (the default is {!char}).
	407	See also {!bytes_of} and {!bytes_readable} for versions without
	408	optional parameters.
	409	@since 0.20 *)
	410
	411	val bytes_of : char t -> bytes t
	412	(** Builds a bytes generator using the given character generator.
	413	@since 0.20 *)
	414
	415	val bytes_printable : bytes t
	416	(** Generator using the {!printable} character generator.
	417	@since 0.20 *)
	418
	419	val bytes_small : bytes t
	420	(** Builds a bytes generator using the {!char} character generator, length is {!small_nat}
	421	@since 0.20 *)
	422
	423	val bytes_small_of : char t -> bytes t
	424	(** Builds a bytes generator using the given character generator, length is {!small_nat}.
	425	@since 0.20 *)
398	426
399	427	val string_size : ?gen:char t -> int t -> string t
400	428	(** Builds a string generator from a (non-negative) size generator.

423	451	val small_string : ?gen:char t -> string t
424	452	(** Builds a string generator, length is {!small_nat}
425	453	Accepts an optional character generator (the default is {!char}). *)
	454
	455	val string_small : string t
	456	(** Builds a string generator using the {!char} character generator, length is {!small_nat}
	457	@since 0.20 *)
	458
	459	val string_small_of : char t -> string t
	460	(** Builds a string generator using the given character generator, length is {!small_nat}.
	461	@since 0.20 *)
426	462
427	463	val small_list : 'a t -> 'a list t
428	464	(** Generates lists of small size (see {!small_nat}).

576	612
577	613	val char : char t (** Character printer. *)
578	614
	615	val bytes : bytes t (** Bytes printer. @since 0.20 *)
	616
579	617	val string : string t (** String printer. *)
580	618
581	619	val option : 'a t -> 'a option t (** Option printer. *)

644	682	val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
645	683	val (>\|=) : 'a t -> ('a -> 'b) -> 'b t
646	684	val append : 'a t -> 'a t -> 'a t
647		val (<+>) : 'a t -> 'a t -> 'a t (** Synonym to {!append}. *)
	685	val (<+>) : 'a t -> 'a t -> 'a t (** Synonym for {!append}. *)
648	686
649	687	val of_list : 'a list -> 'a t
650	688	val of_array : 'a array -> 'a t

708	746
709	747	val option : 'a t -> 'a option t
710	748
	749	val bytes : ?shrink:(char t) -> bytes t
	750	(** @since 0.20 *)
	751
711	752	val string : ?shrink:(char t) -> string t
712	753
713	754	val filter : ('a -> bool) -> 'a t -> 'a t

810	851	val int : int t
811	852	val float : float t
812	853	val string : string t
	854	val bytes : bytes t (** @since 0.20 *)
813	855	val char : char t
814	856
815	857	val make :

1206	1248	@since 0.5.2 *)
1207	1249
1208	1250	val (--) : int -> int -> int arbitrary
1209		(** Synonym to {!int_range}. *)
	1251	(** Synonym for {!int_range}. *)
1210	1252
1211	1253	val int32 : int32 arbitrary
1212	1254	(** Int32 generator. Uniformly distributed. *)

1240	1282	val numeral_char : char arbitrary
1241	1283	(** Uniformly distributed over ['0'..'9']. *)
1242	1284
	1285	val bytes_gen_of_size : int Gen.t -> char Gen.t -> bytes arbitrary
	1286	(** Builds a bytes generator from a (non-negative) size generator and a character generator.
	1287	@since 0.20 *)
	1288
	1289	val bytes_of : char Gen.t -> bytes arbitrary
	1290	(** Generates bytes with a distribution of length of {!Gen.nat}.
	1291	@since 0.20 *)
	1292
	1293	val bytes : bytes arbitrary
	1294	(** Generates bytes with a distribution of length of {!Gen.nat}
	1295	and distribution of characters of [char].
	1296	@since 0.20 *)
	1297
	1298	val bytes_small : bytes arbitrary
	1299	(** Same as {!bytes} but with a small length (ie {!Gen.small_nat} ).
	1300	@since 0.20 *)
	1301
	1302	val bytes_small_of : char Gen.t -> bytes arbitrary
	1303	(** Same as {!bytes_of} but with a small length (ie {!Gen.small_nat} ).
	1304	@since 0.20 *)
	1305
	1306	val bytes_of_size : int Gen.t -> bytes arbitrary
	1307	(** Generates bytes with distribution of characters of [char].
	1308	@since 0.20 *)
	1309
	1310	val bytes_printable : bytes arbitrary
	1311	(** Generates bytes with a distribution of length of {!Gen.nat}
	1312	and distribution of characters of [printable_char].
	1313	@since 0.20 *)
	1314
1243	1315	val string_gen_of_size : int Gen.t -> char Gen.t -> string arbitrary
1244	1316	(** Builds a string generator from a (non-negative) size generator and a character generator. *)
1245	1317
1246	1318	val string_gen : char Gen.t -> string arbitrary
1247	1319	(** Generates strings with a distribution of length of {!Gen.nat}. *)
	1320
	1321	val string_of : char Gen.t -> string arbitrary
	1322	(** Synonym for {!string_gen} added for convenience.
	1323	@since 0.20 *)
1248	1324
1249	1325	val string : string arbitrary
1250	1326	(** Generates strings with a distribution of length of {!Gen.nat}

1253	1329	val small_string : string arbitrary
1254	1330	(** Same as {!string} but with a small length (ie {!Gen.small_nat} ). *)
1255	1331
	1332	val string_small : string arbitrary
	1333	(** Synonym for [small_string] added for convenience.
	1334	@since 0.20 *)
	1335
	1336	val string_small_of : char Gen.t -> string arbitrary
	1337	(** Same as {!string_of} but with a small length (ie {!Gen.small_nat} ).
	1338	@since 0.20 *)
	1339
1256	1340	val small_list : 'a arbitrary -> 'a list arbitrary
1257	1341	(** Generates lists of small size (see {!Gen.small_nat}).
1258	1342	@since 0.5.3 *)

1264	1348	(** Generates strings with a distribution of length of {!Gen.nat}
1265	1349	and distribution of characters of [printable_char]. *)
1266	1350
	1351	val string_printable : string arbitrary
	1352	(** Synonym for [printable_string] added for convenience.
	1353	@since 0.20 *)
	1354
1267	1355	val printable_string_of_size : int Gen.t -> string arbitrary
1268	1356	(** Generates strings with distribution of characters of [printable_char]. *)
	1357
	1358	val string_printable_of_size : int Gen.t -> string arbitrary
	1359	(** Synonym for [printable_string_of_size] added for convenience.
	1360	@since 0.20 *)
1269	1361
1270	1362	val small_printable_string : string arbitrary
1271	1363	(** Generates strings with a length of [small_nat]
1272	1364	and distribution of characters of [printable_char]. *)
1273	1365
	1366	val string_small_printable : string arbitrary
	1367	(** Synonym for [small_printable_string] added for convenience.
	1368	@since 0.20 *)
	1369
1274	1370	val numeral_string : string arbitrary
1275	1371	(** Generates strings with a distribution of length of {!Gen.nat}
1276	1372	and distribution of characters of [numeral_char]. *)
1277	1373
	1374	val string_numeral : string arbitrary
	1375	(** Synonym for [numeral_string] added for convenience.
	1376	@since 0.20 *)
	1377
1278	1378	val numeral_string_of_size : int Gen.t -> string arbitrary
1279	1379	(** Generates strings with a distribution of characters of [numeral_char]. *)
	1380
	1381	val string_numeral_of_size : int Gen.t -> string arbitrary
	1382	(** Synonym for [numeral_string_of_size] added for convenience.
	1383	@since 0.20 *)
1280	1384
1281	1385	val list : 'a arbitrary -> 'a list arbitrary
1282	1386	(** Generates lists with length generated by {!Gen.nat}. *)

+23

-2

src/core/QCheck2.ml less more

697	697	let string_size ?(gen = char) (size : int t) : string t =
698	698	bytes_size ~gen size >\|= Bytes.unsafe_to_string
699	699
	700	let bytes : bytes t = bytes_size nat
	701
	702	let bytes_of gen = bytes_size ~gen nat
	703
	704	let bytes_printable = bytes_size ~gen:printable nat
	705
	706	let bytes_small st = bytes_size small_nat st
	707
	708	let bytes_small_of gen st = bytes_size ~gen small_nat st
	709
700	710	let string : string t = string_size nat
701	711
702	712	let string_of gen = string_size ~gen nat
703	713
704	714	let string_printable = string_size ~gen:printable nat
705	715
706		let small_string ?gen st = string_size ?gen small_nat st
	716	let string_small st = string_size small_nat st
	717
	718	let string_small_of gen st = string_size ~gen small_nat st
	719
	720	let small_string ?(gen=char) = string_small_of gen
707	721
708	722	let small_list gen = list_size small_nat gen
709	723

775	789	let bool = string_of_bool
776	790
777	791	let float = string_of_float
	792
	793	let bytes = Bytes.to_string
778	794
779	795	let string s = Printf.sprintf "%S" s
780	796

961	977
962	978	let char x = Char.code x
963	979
	980	let bytes (x:bytes) = Hashtbl.hash x
	981
964	982	let string (x:string) = Hashtbl.hash x
965	983
966	984	let option f = function

977	995	type 'a t = 'a -> 'a -> bool
978	996
979	997	let int : int t = (=)
	998
	999	let bytes : bytes t = (=)
980	1000
981	1001	let string : string t = (=)
982	1002

1018	1038	let int : int t = make ~hash:H.int ~eq:Eq.int Print.int
1019	1039
1020	1040	let float : float t = make ~eq:Eq.float Print.float
	1041
	1042	let bytes = make ~hash:H.bytes ~eq:Eq.bytes Print.bytes
1021	1043
1022	1044	let string = make ~hash:H.string ~eq:Eq.string Print.string
1023	1045

1507	1529	let make_neg = make' ~negative:true
1508	1530
1509	1531	let test_get_count (Test cell) = get_count cell
1510
1511	1532	let test_get_long_factor (Test cell) = get_long_factor cell
1512	1533
1513	1534	(** {6 Running the test} *)

+73

-2

src/core/QCheck2.mli less more

288	288	Shrinks towards ['0'].
289	289	*)
290	290
	291	val bytes_size : ?gen:char t -> int t -> bytes t
	292	(** Builds a bytes generator from a (non-negative) size generator.
	293	Accepts an optional character generator (the default is {!char}).
	294
	295	Shrinks on the number of characters first, then on the characters.
	296
	297	@since 0.20 *)
	298
	299	val bytes : bytes t
	300	(** Bytes generator using the {!char} character generator. Bytes size is generated by {!nat}.
	301	See also {!bytes_of} and {!bytes_printable} for versions with
	302	custom char generator.
	303
	304	Shrinks on the number of characters first, then on the characters.
	305
	306	@since 0.20 *)
	307
	308	val bytes_of : char t -> bytes t
	309	(** Builds a bytes generator using the given character generator.
	310
	311	Shrinks on the number of characters first, then on the characters.
	312
	313	@since 0.20 *)
	314
	315	val bytes_printable : bytes t
	316	(** Generator using the {!printable} character generator.
	317
	318	Shrinks on the number of characters first, then on the characters.
	319
	320	@since 0.20 *)
	321
	322	val bytes_small : bytes t
	323	(** Builds a bytes generator using the {!char} character generator, length is {!small_nat}.
	324
	325	Shrinks on the number of characters first, then on the characters.
	326
	327	@since 0.20 *)
	328
	329	val bytes_small_of : char t -> bytes t
	330	(** Builds a bytes generator using the given character generator, length is {!small_nat}.
	331
	332	Shrinks on the number of characters first, then on the characters.
	333
	334	@since 0.20 *)
	335
291	336	val string_size : ?gen:char t -> int t -> string t
292	337	(** Builds a string generator from a (non-negative) size generator.
293	338	Accepts an optional character generator (the default is {!char}).

318	363
319	364	@since 0.11 *)
320	365
	366	val string_small : string t
	367	(** Builds a string generator using the {!char} characher generator, length is {!small_nat}.
	368
	369	Shrinks on the number of characters first, then on the characters.
	370
	371	@since 0.20
	372	*)
	373
	374	val string_small_of : char t -> string t
	375	(** Builds a string generator using the given characher generator, length is {!small_nat}.
	376
	377	Shrinks on the number of characters first, then on the characters.
	378
	379	@since 0.20
	380	*)
	381
321	382	val small_string : ?gen:char t -> string t
322	383	(** Builds a string generator, length is {!small_nat}.
323	384	Accepts an optional character generator (the default is {!char}).
324
325	385	Shrinks on the number of characters first, then on the characters.
	386	This function is kept for backward compatibility:
	387	The optional argument is in fact a mandatory [option], see c-cube/qcheck#162.
	388	Use {!string_small} instead.
326	389	*)
327	390
328	391	val pure : 'a -> 'a t

1034	1097
1035	1098	val char : char t
1036	1099	(** [char] is a printer of character. *)
	1100
	1101	val bytes : bytes t
	1102	(** [bytes] is a printer of bytes.
	1103	@since 0.20 *)
1037	1104
1038	1105	val string : string t
1039	1106	(** [string] is a printer of string. *)

1233	1300	val float : float t
1234	1301	(** [float] is an observable of [float]. *)
1235	1302
	1303	val bytes : bytes t
	1304	(** [bytes] is an observable of [bytes].
	1305	@since 0.20 *)
	1306
1236	1307	val string : string t
1237	1308	(** [string] is an observable of [string]. *)
1238	1309

1273	1344	(** [quad o1 o2 o3 o4] is an observable of quadruples of [('a * 'b * 'c * 'd)]. *)
1274	1345	end
1275	1346
1276
	1347
1277	1348	(** Utils on combining function arguments. *)
1278	1349	module Tuple : sig
1279	1350	(** Heterogeneous tuple, used to pass any number of arguments to

+177

-73

src/ppx_deriving_qcheck/QCheck_generators.ml less more

2	2	(** This module contains all generators from QCheck used to
3	3	derive a type declaration *)
4	4
	5	(** {2. Version} *)
	6
	7	type version = [`QCheck \| `QCheck2]
	8
	9	let to_module : version -> string = function
	10	\| `QCheck -> "QCheck"
	11	\| `QCheck2 -> "QCheck2"
	12
	13	let with_prefix loc version prefix x =
	14	let (module A) = Ast_builder.make loc in
	15	A.Located.mk @@ Ldot (Ldot (Lident (to_module version), prefix), x)
	16	\|> A.pexp_ident
	17
	18	let with_prefix_gen loc version x = with_prefix loc version "Gen" x
	19
	20	let with_prefix_obs loc version x = with_prefix loc version "Observable" x
	21
	22	let apply1 loc f a = [%expr [%e f] [%e a]]
	23
	24	let apply2 loc f a b = [%expr [%e f] [%e a] [%e b]]
	25
	26	let apply3 loc f a b c = [%expr [%e f] [%e a] [%e b] [%e c]]
	27
	28	let apply4 loc f a b c d = [%expr [%e f] [%e a] [%e b] [%e c] [%e d]]
	29
5	30	(** {2. Type} *)
6	31
7		let ty = Ldot (Ldot (Lident "QCheck", "Gen"), "t")
	32	let ty version = Ldot (Ldot (Lident (to_module version), "Gen"), "t")
8	33
9	34	(** {2. Primitive generators} *)
10	35
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.option [%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]]
	36	let unit loc version = with_prefix_gen loc version "unit"
	37
	38	let int loc version = with_prefix_gen loc version "int"
	39
	40	let string loc version = with_prefix_gen loc version "string"
	41
	42	let char loc version = with_prefix_gen loc version "char"
	43
	44	let bool loc version = with_prefix_gen loc version "bool"
	45
	46	let float loc version = with_prefix_gen loc version "float"
	47
	48	let int32 loc version = with_prefix_gen loc version "ui32"
	49
	50	let int64 loc version = with_prefix_gen loc version "ui64"
	51
	52	let option ~loc ~version e =
	53	let gen = with_prefix_gen loc version "option" in
	54	apply1 loc gen e
	55
	56	let list ~loc ~version e =
	57	let gen = with_prefix_gen loc version "list" in
	58	apply1 loc gen e
	59
	60	let array ~loc ~version e =
	61	let gen = with_prefix_gen loc version "array" in
	62	apply1 loc gen e
32	63
33	64	(** {2. Generator combinators} *)
34	65
35		let pure ~loc x = [%expr QCheck.Gen.pure [%e x]]
36
37		let frequency ~loc l =
	66	let pure ~loc ~version e =
	67	let gen = with_prefix_gen loc version "pure" in
	68	apply1 loc gen e
	69
	70	let frequency ~loc ~version l =
38	71	match l with
39	72	\| [%expr [([%e? _], [%e? x])]] -> x
40	73	\| _ ->
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]]
	74	let gen = with_prefix_gen loc version "frequency" in
	75	apply1 loc gen l
	76
	77	let map ~loc ~version pat expr gen =
	78	let f = with_prefix_gen loc version "map" in
	79	apply2 loc f [%expr fun [%p pat] -> [%e expr]] gen
	80
	81	let pair ~loc ~version a b =
	82	let gen = with_prefix_gen loc version "pair" in
	83	apply2 loc gen a b
	84
	85	let triple ~loc ~version a b c =
	86	let gen = with_prefix_gen loc version "triple" in
	87	apply3 loc gen a b c
	88
	89	let quad ~loc ~version a b c d =
	90	let gen = with_prefix_gen loc version "quad" in
	91	apply4 loc gen a b c d
	92
	93	let sized ~loc ~version e =
	94	let gen = with_prefix_gen loc version "sized" in
	95	apply1 loc gen e
	96
	97	let fix ~loc ~version e =
	98	let gen = with_prefix_gen loc version "fix" in
	99	apply1 loc gen e
60	100
61	101	(** Observable generators *)
62	102	module Observable = struct
63	103	(** {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]]
	104	let unit loc version = with_prefix_obs loc version "unit"
	105
	106	let int loc version = with_prefix_obs loc version "int"
	107
	108	let string loc version = with_prefix_obs loc version "string"
	109
	110	let char loc version = with_prefix_obs loc version "char"
	111
	112	let bool loc version = with_prefix_obs loc version "bool"
	113
	114	let float loc version = with_prefix_obs loc version "float"
	115
	116	let int32 loc version = with_prefix_obs loc version "int32"
	117
	118	let int64 loc version = with_prefix_obs loc version "int64"
	119
	120	let option ~loc ~version e =
	121	let obs = with_prefix_obs loc version "option" in
	122	apply1 loc obs e
	123
	124	let list ~loc ~version e =
	125	let obs = with_prefix_obs loc version "list" in
	126	apply1 loc obs e
	127
	128	let array ~loc ~version e =
	129	let obs = with_prefix_obs loc version "array" in
	130	apply1 loc obs e
85	131
86	132	(** {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]]
	133	let pair ~loc ~version a b =
	134	let obs = with_prefix_obs loc version "pair" in
	135	apply2 loc obs a b
	136
	137	let triple ~loc ~version a b c =
	138	let obs = with_prefix_obs loc version "triple" in
	139	apply3 loc obs a b c
	140
	141	let quad ~loc ~version a b c d =
	142	let obs = with_prefix_obs loc version "quad" in
	143	apply4 loc obs a b c d
	144
	145	let fun_nary ~loc ~version left right gen =
	146	match version with
	147	\| `QCheck ->
	148	let arb = [%expr QCheck.make [%e gen]] in
	149	[%expr QCheck.fun_nary QCheck.Tuple.([%e left] @-> [%e right]) [%e arb] \|> QCheck.gen]
	150	\| `QCheck2 ->
	151	[%expr QCheck2.fun_nary QCheck2.Tuple.([%e left] @-> [%e right]) [%e gen]]
95	152	end
	153
	154	module Make (Version : sig val version : version end) = struct
	155	let version = Version.version
	156	let ty = ty version
	157	let unit loc = unit loc version
	158	let int loc = int loc version
	159	let string loc = string loc version
	160	let char loc = char loc version
	161	let bool loc = bool loc version
	162	let float loc = float loc version
	163	let int32 loc = int32 loc version
	164	let int64 loc = int64 loc version
	165	let option ~loc = option ~loc ~version
	166	let list ~loc = list ~loc ~version
	167	let array ~loc = array ~loc ~version
	168	let pure ~loc x = pure ~loc ~version x
	169	let frequency ~loc l = frequency ~loc ~version l
	170	let map ~loc pat expr gen = map ~loc ~version pat expr gen
	171	let pair ~loc a b = pair ~loc ~version a b
	172	let triple ~loc a b c = triple ~loc ~version a b c
	173	let quad ~loc a b c d = quad ~loc ~version a b c d
	174	let sized ~loc e = sized ~loc ~version e
	175	let fix ~loc e = fix ~loc ~version e
	176	module Observable = struct
	177	let unit loc = Observable.unit loc version
	178	let int loc = Observable.int loc version
	179	let string loc = Observable.string loc version
	180	let char loc = Observable.char loc version
	181	let bool loc = Observable.bool loc version
	182	let float loc = Observable.float loc version
	183	let int32 loc = Observable.int32 loc version
	184	let int64 loc = Observable.int64 loc version
	185	let option ~loc e = Observable.option ~loc ~version e
	186	let list ~loc e = Observable.list ~loc ~version e
	187	let array ~loc e = Observable.array ~loc ~version e
	188	let pair ~loc a b = Observable.pair ~loc ~version a b
	189	let triple ~loc a b c = Observable.triple ~loc ~version a b c
	190	let quad ~loc a b c d = Observable.quad ~loc ~version a b c d
	191	let fun_nary ~loc left right gen = Observable.fun_nary ~loc ~version left right gen
	192	end
	193	end
	194
	195	module QCheck = Make (struct let version = `QCheck end)
	196	module QCheck2 = Make (struct let version = `QCheck2 end)
	197	module type S = module type of QCheck
	198
	199	let make version = (module Make (struct let version = version end) : S)

+161

-49

src/ppx_deriving_qcheck/ppx_deriving_qcheck.ml less more

10	10	{[
11	11	module Tree : sig
12	12	type t
13
	13	val gen_sized : int -> t QCheck.Gen.t
14	14	val gen : t QCheck.Gen.t
	15	val arb_sized : int -> t QCheck.arbitrary
	16	val arb : t QCheck.arbitrary
15	17	end = struct
16	18	type t = Leaf \| Node of int * t * t
17	19	[@@deriving qcheck]

33	35	let s = name ?sized s in
34	36	A.pvar s
35	37
	38	(** [name_gen_to_arb name] creates the arb name based on the generator [name] *)
	39	let name_gen_to_arb = function
	40	\| "gen" -> "arb"
	41	\| name ->
	42	let n = String.length name in
	43	let suffix = String.sub name 3 (n - 3) in
	44	"arb" ^ suffix
	45
	46	(** [pattern_name pat] tries to find the [pattern] name. *)
	47	let pattern_name pat : string =
	48	let loc = pat.ppat_loc in
	49	match pat.ppat_desc with
	50	\| Ppat_var var -> var.txt
	51	\| _ ->
	52	Ppxlib.Location.raise_errorf ~loc
	53	"Could not extract name from this pattern"
	54
	55	(** [args_and_body expr] extracts the args used in [expr] with
	56	the actual body using these args. *)
	57	let rec args_and_body expr : (string list * expression) =
	58	match expr.pexp_desc with
	59	\| Pexp_fun (Nolabel, _, pat, expr) ->
	60	let (args, body) = args_and_body expr in
	61	(pattern_name pat :: args, body)
	62	\| _ -> ([], expr)
	63
36	64	(** {2. Recursive generators} *)
37	65
38	66	(** Recursive generators must be treated separatly:

60	88	(** [env] contains:
61	89	- the list of recursive types during the derivation
62	90	- the list of types to derive (i.e. mutual types)
63		- the current type to derive *)
	91	- the current type to derive
	92
	93	It also contains the current version of QCheck we derive *)
64	94	type env = {
	95	version : [`QCheck \| `QCheck2];
65	96	rec_types : string list;
66	97	curr_types : string list;
67	98	curr_type : string;
68	99	}
69	100
70	101	let is_rec env x = List.mem x env.rec_types
	102
	103	let get_version env = env.version
71	104	end
72	105
73	106	let rec longident_to_str = function

202	235
203	236	Therefore, [is_rec] and [to_gen] are different for variants and polymorphic
204	237	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
	238	let gen_sized ~loc ~env (is_rec : 'a -> bool) (to_gen : 'a -> expression) (xs : 'a list) =
	239	let (module A) = Ast_builder.make loc in
	240	let (module G) = G.make (Env.get_version env) in
207	241	let leaves =
208	242	List.filter (fun x -> not (is_rec x)) xs \|> List.map to_gen
209	243	in

216	250	G.frequency ~loc (A.elist nodes)
217	251	else
218	252	let nodes = List.map to_gen nodes in
219		let leaves = A.elist leaves \|> G.frequency ~loc
	253	let leaves = A.elist leaves \|> G.frequency ~loc
220	254	and nodes = A.elist (leaves @ nodes) \|> G.frequency ~loc in
221	255	[%expr
222	256	match n with

241	275	let gen = QCheck.Gen.(map (fun (x, y) -> Foo (x, y)) (pair int int))
242	276	]}
243	277	*)
244		let gen_tuple ~loc ?(f = fun x -> x) tys =
	278	let gen_tuple ~loc ~env ?(f = fun x -> x) tys =
245	279	let tuple = Tuple.from_list tys in
246		let gen = Tuple.to_gen ~loc tuple in
	280	let gen = Tuple.to_gen ~loc ~version:(Env.get_version env) tuple in
247	281	let expr = Tuple.to_expr ~loc tuple \|> f in
248	282	let pat = Tuple.to_pat ~loc tuple in
249		G.map ~loc pat expr gen
	283	G.map ~loc ~version:(Env.get_version env) pat expr gen
250	284
251	285	(** [gen_record loc gens ?f label_decls] transforms [gens] and [label_decls] to
252	286	a record generator.

267	301	]}
268	302
269	303	*)
270		let gen_record ~loc ~gens ?(f = fun x -> x) xs =
	304	let gen_record ~loc ~env ~gens ?(f = fun x -> x) xs =
271	305	let (module A) = Ast_builder.make loc in
272	306	let tuple = Tuple.from_list gens in
273		let gen = Tuple.to_gen ~loc tuple in
	307	let gen = Tuple.to_gen ~loc ~version:(Env.get_version env) tuple in
274	308	let pat = Tuple.to_pat ~loc tuple in
275	309	(* TODO: this should be handled in {!Tuple} *)
276	310	let gens =

288	322	in
289	323	let expr = A.pexp_record fields None \|> f in
290	324
291		G.map ~loc pat expr gen
	325	G.map ~loc ~version:(Env.get_version env) pat expr gen
292	326
293	327	(** {2. Core derivation} *)
294	328
295	329	(** [gen_from_type typ] performs the AST traversal and derivation to qcheck generators *)
296	330	let rec gen_from_type ~loc ~env typ =
	331	let (module G) = G.make (Env.get_version env) in
297	332	Option.value (Attributes.gen typ)
298	333	~default:
299	334	(match typ with

310	345	\| [%type: [%t? typ] array] -> G.array ~loc (gen_from_type ~loc ~env typ)
311	346	\| { ptyp_desc = Ptyp_tuple typs; _ } ->
312	347	let tys = List.map (gen_from_type ~loc ~env) typs in
313		gen_tuple ~loc tys
	348	gen_tuple ~loc ~env tys
314	349	\| { ptyp_desc = Ptyp_constr ({ txt = ty; _ }, args); _ } ->
315	350	let args = List.map (gen_from_type ~loc ~env) args in
316	351	gen_longident ~loc ~env ty args

334	369	let gen =
335	370	match pcd_args with
336	371	\| Pcstr_tuple [] \| Pcstr_record [] ->
337		G.pure ~loc @@ A.econstruct constr_decl None
	372	G.pure ~loc ~version:(Env.get_version env) @@ A.econstruct constr_decl None
338	373	\| Pcstr_tuple xs ->
339	374	let tys = List.map (gen_from_type ~loc ~env) xs in
340		gen_tuple ~loc ~f:mk_constr tys
	375	gen_tuple ~loc ~env ~f:mk_constr tys
341	376	\| Pcstr_record xs ->
342	377	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
	378	gen_record ~loc ~env ~f:mk_constr ~gens:tys xs
344	379	in
345	380
346	381	A.pexp_tuple [ Option.value ~default:[%expr 1] weight; gen ]
347	382
348	383	and gen_from_variant ~loc ~env rws =
349	384	let (module A) = Ast_builder.make loc in
	385	let (module G) = G.make (Env.get_version env) in
350	386	let is_rec = is_rec_row_field env in
351	387	let to_gen (row : row_field) : expression =
352	388	let w =

355	391	let gen =
356	392	match row.prf_desc with
357	393	\| Rinherit typ -> gen_from_type ~loc ~env typ
358		\| Rtag (label, _, []) -> G.pure ~loc @@ A.pexp_variant label.txt None
	394	\| Rtag (label, _, []) ->
	395	G.pure ~loc @@ A.pexp_variant label.txt None
359	396	\| Rtag (label, _, typs) ->
360	397	let f expr = A.pexp_variant label.txt (Some expr) in
361		gen_tuple ~loc ~f (List.map (gen_from_type ~loc ~env) typs)
	398	gen_tuple ~loc ~env ~f (List.map (gen_from_type ~loc ~env) typs)
362	399	in
363	400	[%expr [%e w], [%e gen]]
364	401	in
365		let gen = gen_sized ~loc is_rec to_gen rws in
	402	let gen = gen_sized ~loc ~env is_rec to_gen rws in
366	403	let typ_t = A.ptyp_constr (A.Located.mk @@ Lident env.curr_type) [] in
367	404	let typ_gen = A.Located.mk G.ty in
368	405	let typ = A.ptyp_constr typ_gen [ typ_t ] in
369	406	[%expr ([%e gen] : [%t typ])]
370	407
371	408	and gen_from_arrow ~loc ~env left right =
	409	let (module Gen) = G.make (Env.get_version env) in
	410	let open Gen.Observable in
372	411	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)
	412	\| [%type: unit] -> unit loc
	413	\| [%type: bool] -> bool loc
	414	\| [%type: int] -> int loc
	415	\| [%type: float] -> float loc
	416	\| [%type: string] -> string loc
	417	\| [%type: char] -> char loc
	418	\| [%type: [%t? typ] option] -> option ~loc (observable typ)
	419	\| [%type: [%t? typ] array] -> array ~loc (observable typ)
	420	\| [%type: [%t? typ] list] -> list ~loc (observable typ)
382	421	\| { ptyp_desc = Ptyp_tuple xs; _ } ->
383	422	let obs = List.map observable xs in
384		Tuple.from_list obs \|> Tuple.to_obs ~loc
	423	Tuple.from_list obs \|> Tuple.to_obs ~version:(Env.get_version env) ~loc
385	424	\| { ptyp_loc = loc; _ } ->
386	425	Ppxlib.Location.raise_errorf ~loc
387	426	"This type is not supported in ppx_deriving_qcheck"

393	432	(res, [%expr [%e obs] @-> [%e xs]])
394	433	\| x -> (gen_from_type ~loc ~env x, [%expr o_nil])
395	434	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]
	435	let gen, right = aux right in
	436	let left = observable left in
	437	fun_nary ~loc left right gen
402	438
403	439	(** [gen_from_type_declaration loc td] creates a generator from the type declaration.
404	440

431	467	match td.ptype_kind with
432	468	\| Ptype_variant xs ->
433	469	let is_rec cd = is_rec_constr_decl env cd in
434		gen_sized ~loc is_rec (gen_from_constr ~loc ~env) xs
	470	gen_sized ~loc ~env is_rec (gen_from_constr ~loc ~env) xs
435	471	\| Ptype_record xs ->
436	472	let gens = List.map (fun x -> gen_from_type ~loc ~env x.pld_type) xs in
437		gen_record ~loc ~gens xs
	473	gen_record ~loc ~env ~gens xs
438	474	\| _ ->
439	475	let typ = Option.get td.ptype_manifest in
440	476	gen_from_type ~loc ~env typ

454	490	let gen_sized = name ~sized:true ty \|> A.evar in
455	491	let gen_normal =
456	492	Args.curry_args ~loc args_pat
457		(G.sized ~loc (Args.apply_args ~loc args_expr gen_sized))
	493	(G.sized ~loc ~version:(Env.get_version env) (Args.apply_args ~loc args_expr gen_sized))
458	494	in
459	495	`Recursive (
460	496	[%stri let rec [%p pat_gen_sized] = [%e gen]],

483	519	let mutual_gens = A.pstr_value Recursive gens in
484	520	mutual_gens :: normal_gens
485	521
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
	522	(** [derive_gens ~version ~loc xs] creates generators for type declaration in [xs].
	523
	524	The generators can either be [QCheck.Gen.t] or [QCheck2.Gen.t] based on
	525	[version]. *)
	526	let derive_gens ~version ~loc (xs : rec_flag * type_declaration list) : structure =
489	527	let add_if_rec env typ x =
490	528	if is_rec_type_decl env typ then
491		{ env with rec_types = x :: env.rec_types}
	529	Env.{ env with rec_types = x :: env.rec_types}
492	530	else env
493	531	in
494	532	match xs with
495	533	\| (_, [ x ]) ->
496	534	let typ_name = x.ptype_name.txt in
497		let env = { curr_type = typ_name; rec_types = []; curr_types = [typ_name] } in
	535	let env = Env.{ curr_type = typ_name; rec_types = []; curr_types = [typ_name]; version } in
498	536	let env = add_if_rec env x typ_name in
499	537	(match gen_from_type_declaration ~loc ~env x with
500	538	\| `Recursive (gen_sized, gen) -> [gen_sized; gen]
501	539	\| `Normal gen -> [gen])
502	540	\| _, xs ->
503	541	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
	542	let env = Env.{ curr_type = ""; rec_types = []; curr_types = typ_names; version } in
505	543	let env =
506	544	List.fold_left
507	545	(fun env x -> add_if_rec env x x.ptype_name.txt)

514	552	in
515	553	mutually_recursive_gens ~loc gens
516	554
	555	(** [derive_arb gen] creates an arbitrary declaration based on [gen]. We call
	556	QCheck.make on the derived generator..
	557
	558	It fetches the generator name and its parameters.
	559
	560	e.g.
	561	{[
	562	type 'a list = Cons of 'a * 'a list \| Nil
	563	[@@deriving qcheck]
	564
	565	(* produces => *)
	566
	567	let rec gen_list_sized gen_a =
	568	match n with
	569	\| ...
	570
	571	let gen_list_gen_a = QCheck.Gen.sized @@ (gen_list_sized gen_a)
	572
	573	let arb_list_sized gen_a = QCheck.make @@ (gen_list_sized gen_a)
	574
	575	let arb_list gen_a = QCheck.make @@ (gen_list gen_a)
	576	]}
	577	*)
	578	let derive_arb gen =
	579	let loc = gen.pstr_loc in
	580	let (module A) = Ast_builder.make loc in
	581	let (args, body, gen_name) =
	582	match gen with
	583	\| [%stri let [%p? pat] = [%e? body]]
	584	\| [%stri let rec [%p? pat] = [%e? body]] ->
	585	let (args, body) = args_and_body body in
	586	let gen_name = pattern_name pat in
	587	(args, body, gen_name)
	588	\| _ -> assert false
	589	in
	590	let args_pat = List.map A.pvar args in
	591	let args_expr = List.map A.evar args in
	592
	593	let arb_pat = A.pvar (name_gen_to_arb gen_name) in
	594	let body =
	595	match body with
	596	\| [%expr QCheck.sized @@ [%e? _]] ->
	597	A.evar gen_name \|>
	598	Args.apply_args ~loc args_expr \|>
	599	fun e -> [%expr QCheck.make @@ [%e e]]
	600	\| _ ->
	601	A.evar gen_name \|>
	602	Args.apply_args ~loc args_expr
	603	in
	604	let body = Args.curry_args ~loc args_pat [%expr QCheck.make @@ [%e body]] in
	605	[%stri let [%p arb_pat] = [%e body]]
	606
	607	let derive_arbs ~loc xs =
	608	let gens = derive_gens ~loc ~version:`QCheck xs in
	609	(* When generators are mutual, they are nested in a {[ let rec gen = ... and gen .. ]},
	610	we want an arbitrary for each generator, so, we flatten them in a list. *)
	611	let flatten_gens =
	612	List.fold_right (fun gen acc ->
	613	match gen.pstr_desc with
	614	\| Pstr_value (_, vbs) ->
	615	List.map (fun vb -> [%stri let [%p vb.pvb_pat] = [%e vb.pvb_expr]]) vbs @ acc
	616	\| _ -> gen :: acc
	617	) gens []
	618	in
	619	gens @ List.map derive_arb flatten_gens
	620
517	621	(** {2. Ppxlib machinery} *)
518	622
519		let create_gen ~ctxt (decls : rec_flag * type_declaration list) : structure =
	623	let create_gens version ~ctxt (decls : rec_flag * type_declaration list) : structure =
520	624	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
	625	derive_gens ~version ~loc decls
	626
	627	let create_arbs ~ctxt (decls : rec_flag * type_declaration list) : structure =
	628	let loc = Expansion_context.Deriver.derived_item_loc ctxt in
	629	derive_arbs ~loc decls
	630
	631	let gen_expander_qcheck = Deriving.Generator.V2.make_noarg create_arbs
	632
	633	let gen_expander_qcheck2 = Deriving.Generator.V2.make_noarg (create_gens `QCheck2)
	634
	635	let _ = Deriving.add "qcheck" ~str_type_decl:gen_expander_qcheck
	636
	637	let _ = Deriving.add "qcheck2" ~str_type_decl:gen_expander_qcheck2

+16

-2

src/ppx_deriving_qcheck/ppx_deriving_qcheck.mli less more

0	0	open Ppxlib
1	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] *)
	2	val derive_gens :
	3	version:[`QCheck \| `QCheck2] ->
	4	loc:location ->
	5	rec_flag * type_declaration list ->
	6	structure
	7	(** [derive_gens ~version ~loc xs] creates generators for type declaration in [xs].
	8
	9	The generators can either be [QCheck.Gen.t] or [QCheck2.Gen.t] based on
	10	[version]. *)
	11
	12	val derive_arbs :
	13	loc:location ->
	14	rec_flag * type_declaration list ->
	15	structure
	16	(** [derive_arbs ~loc xs] creates generators for type declaration in [xs] and
	17	use these lasts to build [QCheck.arbitrary]. *)

+10

-4

src/ppx_deriving_qcheck/tuple.ml less more

97	97	\| Elem a -> a
98	98
99	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
	100	let to_gen ~loc ~version t =
	101	nest
	102	~pair:(G.pair ~loc ~version)
	103	~triple:(G.triple ~loc ~version)
	104	~quad:(G.quad ~loc ~version) t
102	105
103	106	(** [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
	107	let to_obs ~loc ~version t =
	108	nest
	109	~pair:(O.pair ~loc ~version)
	110	~triple:(O.triple ~loc ~version)
	111	~quad:(O.quad ~loc ~version) t
106	112
107	113	let to_pat ~loc t =
108	114	let fresh_id =

-1

src/runner/QCheck_base_runner.ml less more

189	189	; "--debug-shrink-list", Arg.String set_debug_shrink_list, " filter test to debug shrinking on"
190	190	]
191	191	) in
192		Arg.parse_argv argv options (fun _ ->()) "run qtest suite";
	192	Arg.parse_argv argv options (fun _ ->()) "run QCheck test suite";
193	193	let cli_rand = setup_random_state_ ~colors:!colors () in
194	194	{ cli_verbose=verbose(); cli_long_tests=long_tests(); cli_rand;
195	195	cli_print_list= !print_list; cli_slow_test= !slow;

test/core/QCheck2_expect_test.expected.32 less more

Binary diff not shown

test/core/QCheck2_expect_test.expected.64 less more

Binary diff not shown

test/core/QCheck2_expect_test.expected.ocaml5 less more

Binary diff not shown

+46

-0

test/core/QCheck2_tests.ml less more

192	192	Test.make ~name:"nat has right range" ~count:1000 ~print:Print.int
193	193	Gen.nat (fun n -> 0 <= n && n < 10000)
194	194
	195	let bytes_test =
	196	Test.make ~name:"bytes has right length and content" ~count:1000 ~print:Print.bytes
	197	Gen.bytes
	198	(fun s ->
	199	let len = Bytes.length s in
	200	0 <= len && len < 10000
	201	&& Bytes.to_seq s \|>
	202	Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true)
	203
195	204	let string_test =
196	205	Test.make ~name:"string has right length and content" ~count:1000 ~print:Print.string
197	206	Gen.string

307	316	char_dist_issue_23;
308	317	char_test;
309	318	nat_test;
	319	bytes_test;
310	320	string_test;
311	321	pair_test;
312	322	triple_test;

385	395	Test.make ~name:"printable never produces less than '5" ~count:1000 ~print:Print.char
386	396	Gen.numeral (fun c -> c >= '5')
387	397
	398	let bytes_are_empty =
	399	Test.make ~name:"bytes are empty" ~count:1000 ~print:Print.bytes
	400	Gen.bytes (fun s -> s = Bytes.empty)
	401
	402	let bytes_never_has_000_char =
	403	Test.make ~name:"bytes never has a \\000 char" ~count:1000 ~print:Print.bytes
	404	Gen.bytes
	405	(fun s -> Bytes.to_seq s \|> Seq.fold_left (fun acc c -> acc && c <> '\000') true)
	406
	407	let bytes_never_has_255_char =
	408	Test.make ~name:"bytes never has a \\255 char" ~count:1000 ~print:Print.bytes
	409	Gen.bytes
	410	(fun s -> Bytes.to_seq s \|> Seq.fold_left (fun acc c -> acc && c <> '\255') true)
	411
	412	let bytes_unique_chars =
	413	Test.make ~name:"bytes have unique chars" ~count:1000 ~print:Print.bytes
	414	Gen.bytes
	415	(fun s ->
	416	let ch_list = Bytes.to_seq s \|> List.of_seq in
	417	List.length ch_list = List.length (List.sort_uniq Char.compare ch_list))
	418
388	419	let strings_are_empty =
389	420	Test.make ~name:"strings are empty" ~count:1000 ~print:Print.string
390	421	Gen.string (fun s -> s = "")

603	634	char_is_never_abcdef;
604	635	printable_is_never_sign;
605	636	numeral_is_never_less_5;
	637	bytes_are_empty;
	638	bytes_never_has_000_char;
	639	bytes_never_has_255_char;
	640	bytes_unique_chars;
606	641	strings_are_empty;
607	642	string_never_has_000_char;
608	643	string_never_has_255_char;

775	810	Test.make ~name:"numeral char code dist" ~count:500_000 ~stats:[("char code", Char.code)] Gen.numeral (fun _ -> true);
776	811	]
777	812
	813	let bytes_len_tests =
	814	let len = ("len",Bytes.length) in
	815	[
	816	Test.make ~name:"bytes_size len dist" ~count:5_000 ~stats:[len] Gen.(bytes_size (int_range 5 10)) (fun _ -> true);
	817	Test.make ~name:"bytes len dist" ~count:5_000 ~stats:[len] Gen.bytes (fun _ -> true);
	818	Test.make ~name:"bytes_of len dist" ~count:5_000 ~stats:[len] Gen.(bytes_of (return 'a')) (fun _ -> true);
	819	Test.make ~name:"bytes_printable len dist" ~count:5_000 ~stats:[len] Gen.bytes_printable (fun _ -> true);
	820	Test.make ~name:"bytes_small len dist" ~count:5_000 ~stats:[len] Gen.(bytes_small_of char) (fun _ -> true);
	821	]
	822
778	823	let string_len_tests =
779	824	let len = ("len",String.length) in
780	825	[

849	894	[ bool_dist; ]
850	895	@ char_dist_tests
851	896	@ [ tree_depth_test;]
	897	@ bytes_len_tests
852	898	@ string_len_tests
853	899	@ [pair_dist;
854	900	triple_dist;

+18

-13

test/core/QCheck2_unit_tests.ml less more

11	11	\| Seq.Nil -> []
12	12	\| Seq.Cons (t,ts) -> Tree.root t :: (Seq.map Tree.root ts \|> List.of_seq)
13	13
	14	let ocaml_major_version =
	15	try
	16	let major_version_str = List.hd (String.split_on_char '.' Sys.ocaml_version) in
	17	int_of_string major_version_str
	18	with _ -> failwith ("Unknown OCaml version format: " ^ Sys.ocaml_version)
14	19
15	20	module Shrink = struct
16	21	let test_int_towards () =

73	78	Alcotest.(check' (list char))
74	79	~msg:"'k' on repeated failure"
75	80	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) char) \|> repeated_failure)
76		~expected:['k'; 'a'; 'f'; 'h'; 'i'; 'j'];
	81	~expected:(if ocaml_major_version < 5 then ['k'; 'a'; 'f'; 'h'; 'i'; 'j'] else ['>'; 'a'; 'P'; 'G'; 'C'; 'A'; '@'; '?']);
77	82	Alcotest.(check' (list char))
78	83	~msg:"'1' on repeated failure"
79	84	~actual:(Gen.(generate_tree ~rand:(rand_init 3345) char) \|> repeated_failure)
80		~expected:['1'; 'a'; 'I'; '='; '7'; '4'; '2'];
	85	~expected:(if ocaml_major_version < 5 then ['1'; 'a'; 'I'; '='; '7'; '4'; '2'] else ['O'; 'a'; 'X'; 'S'; 'Q'; 'P']);
81	86	Alcotest.(check' (list char))
82	87	~msg:"'k' on repeated success"
83	88	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) char) \|> repeated_success)
84		~expected:['k'; 'a';];
	89	~expected:(if ocaml_major_version < 5 then ['k'; 'a';] else ['>'; 'a']);
85	90	Alcotest.(check' (list char))
86	91	~msg:"'1' on repeated success"
87	92	~actual:(Gen.(generate_tree ~rand:(rand_init 3345) char) \|> repeated_success)
88		~expected:['1'; 'a';]
	93	~expected:(if ocaml_major_version < 5 then ['1'; 'a';] else ['O'; 'a'])
89	94
90	95	let test_char_numeral () =
91	96	Alcotest.(check' (list char))
92	97	~msg:"'3' on repeated failure"
93	98	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) numeral) \|> repeated_failure)
94		~expected:['3'; '0'; '1'; '2'];
	99	~expected:(if ocaml_major_version < 5 then ['3'; '0'; '1'; '2'] else ['0']);
95	100	Alcotest.(check' (list char))
96	101	~msg:"'0' on repeated failure"
97	102	~actual:(Gen.(generate_tree ~rand:(rand_init 3346) numeral) \|> repeated_failure)
98		~expected:['0'];
	103	~expected:(if ocaml_major_version < 5 then ['0'] else ['9'; '0'; '4'; '6'; '7'; '8']);
99	104	Alcotest.(check' (list char))
100	105	~msg:"'3' on repeated success"
101	106	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) numeral) \|> repeated_success)
102		~expected:['3'; '0';];
	107	~expected:(if ocaml_major_version < 5 then ['3'; '0'] else ['0']);
103	108	Alcotest.(check' (list char))
104	109	~msg:"'0' on repeated success"
105	110	~actual:(Gen.(generate_tree ~rand:(rand_init 3346) numeral) \|> repeated_success)
106		~expected:['0';]
	111	~expected:(if ocaml_major_version < 5 then ['0'] else ['9'; '0'])
107	112
108	113	let test_char_printable () =
109	114	Alcotest.(check' (list char))
110	115	~msg:"'l' on repeated failure"
111	116	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) printable) \|> repeated_failure)
112		~expected:['l'; 'a'; 'f'; 'i'; 'j'; 'k'];
	117	~expected:(if ocaml_major_version < 5 then ['l'; 'a'; 'f'; 'i'; 'j'; 'k'] else ['D'; 'a'; '%'; '5'; '='; 'A'; 'C']);
113	118	Alcotest.(check' (list char))
114	119	~msg:"'8' on repeated failure"
115	120	~actual:(Gen.(generate_tree ~rand:(rand_init 3346) printable) \|> repeated_failure)
116		~expected:['8'; 'a'; 'z'; ','; '2'; '5'; '7'];
	121	~expected:(if ocaml_major_version < 5 then ['8'; 'a'; 'z'; ','; '2'; '5'; '7'] else ['#'; 'a'; 'o'; 'v'; 'z'; '!'; '"']);
117	122	Alcotest.(check' (list char))
118	123	~msg:"'l' on repeated success"
119	124	~actual:(Gen.(generate_tree ~rand:(rand_init 1234) printable) \|> repeated_success)
120		~expected:['l'; 'a';];
	125	~expected:(if ocaml_major_version < 5 then ['l'; 'a'] else ['D'; 'a']);
121	126	Alcotest.(check' (list char))
122	127	~msg:"'8' on repeated success"
123	128	~actual:(Gen.(generate_tree ~rand:(rand_init 3346) printable) \|> repeated_success)
124		~expected:['8'; 'a';]
	129	~expected:(if ocaml_major_version < 5 then ['8'; 'a'] else ['#'; 'a'])
125	130
126	131	let tests = ("Shrink", Alcotest.[
127	132	test_case "int_towards" `Quick test_int_towards;

150	155
151	156	let test_gen_option_custom () =
152	157	let nb = test_gen_option ~ratio:(Some 0.5) in
153		let b = nb > 450 && nb < 550 in
	158	let b = nb > 400 && nb < 600 in
154	159	Alcotest.(check bool) "Gen.option produces around 50% of Some" b true
155	160
156	161	let tests =

test/core/QCheck_expect_test.expected.32 less more

Binary diff not shown

test/core/QCheck_expect_test.expected.64 less more

Binary diff not shown

test/core/QCheck_expect_test.expected.ocaml5 less more

Binary diff not shown

+45

-1

test/core/QCheck_tests.ml less more

200	200	Test.make ~name:"nat has right range" ~count:1000
201	201	(make ~print:Print.int Gen.nat) (fun n -> 0 <= n && n < 10000)
202	202
	203	let bytes_test =
	204	Test.make ~name:"bytes has right length and content" ~count:1000
	205	bytes
	206	(fun b ->
	207	let len = Bytes.length b in
	208	0 <= len && len < 10000
	209	&& Bytes.to_seq b \|>
	210	Seq.fold_left (fun acc c -> acc && '\000' <= c && c <= '\255') true)
	211
203	212	let string_test =
204	213	Test.make ~name:"string has right length and content" ~count:1000
205	214	string

388	397	printable_test;
389	398	numeral_test;
390	399	nat_test;
	400	bytes_test;
391	401	string_test;
392	402	pair_test;
393	403	triple_test;

470	480	let numeral_is_never_less_5 =
471	481	Test.make ~name:"printable never produces less than '5" ~count:1000
472	482	numeral_char (fun c -> c >= '5')
	483	let bytes_are_empty =
	484	Test.make ~name:"bytes are empty" ~count:1000
	485	bytes (fun b -> b = Bytes.empty)
	486
	487	let bytes_never_has_000_char =
	488	Test.make ~name:"bytes never has a \\000 char" ~count:1000
	489	bytes
	490	(fun b -> Bytes.to_seq b \|> Seq.fold_left (fun acc c -> acc && c <> '\000') true)
	491
	492	let bytes_never_has_255_char =
	493	Test.make ~name:"bytes never has a \\255 char" ~count:1000
	494	bytes
	495	(fun s -> Bytes.to_seq s \|> Seq.fold_left (fun acc c -> acc && c <> '\255') true)
	496
	497	let bytes_unique_chars =
	498	Test.make ~name:"bytes have unique chars" ~count:1000
	499	bytes
	500	(fun s ->
	501	let ch_list = Bytes.to_seq s \|> List.of_seq in
	502	List.length ch_list = List.length (List.sort_uniq Char.compare ch_list))
473	503
474	504	let strings_are_empty =
475	505	Test.make ~name:"strings are empty" ~count:1000

675	705	char_is_never_abcdef;
676	706	printable_is_never_sign;
677	707	numeral_is_never_less_5;
	708	bytes_are_empty;
	709	bytes_never_has_000_char;
	710	bytes_never_has_255_char;
	711	bytes_unique_chars;
678	712	strings_are_empty;
679	713	string_never_has_000_char;
680	714	string_never_has_255_char;

841	875	Test.make ~name:"numeral char code dist" ~count:500_000 (add_stat ("char code", Char.code) numeral_char) (fun _ -> true);
842	876	]
843	877
	878	let bytes_len_tests =
	879	let len = ("len",Bytes.length) in
	880	[
	881	Test.make ~name:"bytes_size len dist" ~count:5_000 (add_stat len (bytes_of_size (Gen.int_range 5 10))) (fun _ -> true);
	882	Test.make ~name:"bytes len dist" ~count:5_000 (add_stat len bytes) (fun _ -> true);
	883	Test.make ~name:"bytes_of len dist" ~count:5_000 (add_stat len (bytes_of (Gen.return 'a'))) (fun _ -> true);
	884	Test.make ~name:"bytes_small len dist" ~count:5_000 (add_stat len bytes_small) (fun _ -> true);
	885	]
	886
844	887	let string_len_tests =
845	888	let len = ("len",String.length) in
846	889	[
847	890	Test.make ~name:"string_size len dist" ~count:5_000 (add_stat len (string_of_size (Gen.int_range 5 10))) (fun _ -> true);
848	891	Test.make ~name:"string len dist" ~count:5_000 (add_stat len string) (fun _ -> true);
849		Test.make ~name:"string_of len dist" ~count:5_000 (add_stat len (string_gen (Gen.return 'a'))) (fun _ -> true);
	892	Test.make ~name:"string_of len dist" ~count:5_000 (add_stat len (string_of (Gen.return 'a'))) (fun _ -> true);
850	893	Test.make ~name:"printable_string len dist" ~count:5_000 (add_stat len printable_string) (fun _ -> true);
851	894	Test.make ~name:"small_string len dist" ~count:5_000 (add_stat len small_string) (fun _ -> true);
852	895	]

923	966	@ char_dist_tests
924	967	@ [tree_depth_test;
925	968	range_subset_test;]
	969	@ bytes_len_tests
926	970	@ string_len_tests
927	971	@ [pair_dist;
928	972	triple_dist;

-4

test/core/dune less more

0	0	(* -- tuareg -- *)
1	1
	2	let suffix =
	3	try
	4	let major_version = List.hd (String.split_on_char '.' Sys.ocaml_version) in
	5	if int_of_string major_version < 5 then string_of_int Sys.word_size else "ocaml5"
	6	with _ -> failwith ("Unknown OCaml version format: " ^ Sys.ocaml_version)
	7
2	8	let dune = Printf.sprintf {\|
3
4	9	(library
5	10	(name QCheck_tests)
6	11	(modules QCheck_tests)

25	30	(rule
26	31	(alias runtest)
27	32	(package qcheck-core)
28		(action (diff QCheck_expect_test.expected.%i QCheck_expect_test.out)))
	33	(action (diff QCheck_expect_test.expected.%s QCheck_expect_test.out)))
29	34
30	35	(executable
31	36	(name QCheck2_expect_test)

41	46	(rule
42	47	(alias runtest)
43	48	(package qcheck-core)
44		(action (diff QCheck2_expect_test.expected.%i QCheck2_expect_test.out)))
	49	(action (diff QCheck2_expect_test.expected.%s QCheck2_expect_test.out)))
45	50
46	51	(tests
47	52	(names QCheck_unit_tests QCheck2_unit_tests)

54	59	(modules shrink_benchmark)
55	60	(libraries qcheck-core qcheck-core.runner QCheck_tests QCheck2_tests))
56	61
57		\|} Sys.word_size Sys.word_size
	62	\|} suffix suffix
58	63
59	64	let () = Jbuild_plugin.V1.send dune

-12

~~test/ppx_deriving_qcheck/deriver/dune~~ less more

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

-15

~~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

+12

-0

test/ppx_deriving_qcheck/deriver/qcheck/dune less more

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

+17

-0

test/ppx_deriving_qcheck/deriver/qcheck/helpers.ml less more

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

+89

-0

test/ppx_deriving_qcheck/deriver/qcheck/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:"int <=> deriving int" ~eq:Alcotest.int int arb_int'
	11
	12	type unit' = unit [@@deriving qcheck]
	13
	14	(* Pretty useless though, but, meh *)
	15	let test_unit () =
	16	test_compare ~msg:"unit <=> deriving unit" ~eq:Alcotest.unit unit arb_unit'
	17
	18	type string' = string [@@deriving qcheck]
	19
	20	let test_string () =
	21	test_compare ~msg:"string <=> deriving string" ~eq:Alcotest.string string arb_string'
	22
	23	type char' = char [@@deriving qcheck]
	24
	25	let test_char () =
	26	test_compare ~msg:"char <=> deriving char" ~eq:Alcotest.char char arb_char'
	27
	28	type bool' = bool [@@deriving qcheck]
	29
	30	let test_bool () =
	31	test_compare ~msg:"bool <=> deriving bool" ~eq:Alcotest.bool bool arb_bool'
	32
	33	type float' = float [@@deriving qcheck]
	34
	35	let test_float () =
	36	test_compare ~msg:"float <=> deriving float" ~eq:(Alcotest.float 0.) float arb_float'
	37
	38	type int32' = int32 [@@deriving qcheck]
	39
	40	let test_int32 () =
	41	test_compare ~msg:"int32 <=> deriving int32" ~eq:Alcotest.int32 int32 arb_int32'
	42
	43	type int64' = int64 [@@deriving qcheck]
	44
	45	let test_int64 () =
	46	test_compare ~msg:"int64 <=> deriving int64" ~eq:Alcotest.int64 int64 arb_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:"option <=> deriving opt"
	53	~eq:Alcotest.(option int)
	54	(option (make zero)) (arb_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:"array <=> deriving array"
	61	~eq:Alcotest.(array int)
	62	(array (make zero)) (arb_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:"list <=> deriving list"
	69	~eq:Alcotest.(list int)
	70	(list (make zero)) (arb_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	])]

+38

-0

test/ppx_deriving_qcheck/deriver/qcheck/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	val arb : int QCheck.arbitrary
	8	end
	9
	10	module Q : S = struct
	11	type t = int [@@deriving qcheck]
	12	end
	13
	14	module F (X : S) = struct
	15	type t = X.t [@@deriving qcheck]
	16	end
	17
	18	module G = F (Q)
	19
	20	type t = Q.t [@@deriving qcheck]
	21
	22	type u = G.t [@@deriving qcheck]
	23
	24	let test_module () =
	25	test_compare ~msg:"Gen.int <=> deriving Q.t" ~eq:Alcotest.int int arb
	26
	27	let test_functor () =
	28	test_compare ~msg:"Gen.int <=> deriving F.t" ~eq:Alcotest.int int arb_u
	29
	30	(** {2. Execute tests} *)
	31
	32	let () = Alcotest.run "Test_Qualified_names"
	33	[("Qualified names",
	34	Alcotest.[
	35	test_case "test_module" `Quick test_module;
	36	test_case "test_functor" `Quick test_functor
	37	])]

+63

-0

test/ppx_deriving_qcheck/deriver/qcheck/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 arb_env_ref =
	24	map (fun (rec_types, curr_types, curr_type) ->
	25	{ rec_types; curr_types; curr_type })
	26	(triple (list string) (list string) string)
	27
	28	let test_env () =
	29	test_compare ~msg:"arb_env ref <=> deriving env"
	30	~eq:eq_env arb_env_ref arb_env
	31
	32	type color = Color of { red : float; green : float; blue : float }
	33	[@@deriving qcheck]
	34
	35	let pp_color fmt (Color {red; green; blue}) =
	36	let open Format in
	37	fprintf fmt {\|Color {
	38	red = %a;
	39	green = %a;
	40	blue = %a;
	41	}\|}
	42	pp_print_float red
	43	pp_print_float green
	44	pp_print_float blue
	45
	46	let eq_color = Alcotest.of_pp pp_color
	47
	48	let arb_color_ref =
	49	map (fun (red, green, blue) -> Color {red; green; blue}) (triple float float float)
	50
	51	let test_color () =
	52	test_compare ~msg:"arb_color ref <=> deriving color"
	53	~eq:eq_color arb_color_ref arb_color
	54
	55	(** {2. Execute tests} *)
	56
	57	let () = Alcotest.run "Test_Record"
	58	[("Record",
	59	Alcotest.[
	60	test_case "test_env" `Quick test_env;
	61	test_case "test_color" `Quick test_color;
	62	])]

+80

-0

test/ppx_deriving_qcheck/deriver/qcheck/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 arb_tree_ref gen =
	20	let open Gen in
	21	make @@ 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 arb_tree_candidate = arb_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	(arb_tree_ref gen) (arb_tree gen)
	37
	38	let test_leaf =
	39	Test.make
	40	~name:"arb_tree_sized 0 = Node (_, Leaf, Leaf)"
	41	(arb_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 `arb_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:"arb_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	])]

+911

-0

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

+106

-0

test/ppx_deriving_qcheck/deriver/qcheck/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/qcheck/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 arb = oneofl [Red; Green; Blue]
	19
	20	let test_variants () =
	21	test_compare ~msg:"Gen.oneofl <=> deriving variants" ~eq:eq_colors arb arb_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 arb_poly = oneofl [`Red; `Green; `Blue]
	35
	36	let test_poly_variants () =
	37	test_compare ~msg:"Gen.oneofl <=> deriving variants"
	38	~eq:eq_poly_colors arb_poly arb_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:"arb_letters always produces B"
	49	arb_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:"arb_poly_letters always produces B"
	64	arb_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	])]

+12

-0

test/ppx_deriving_qcheck/deriver/qcheck2/dune less more

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

+15

-0

test/ppx_deriving_qcheck/deriver/qcheck2/helpers.ml less more

	0	open QCheck2
	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/qcheck2/test_primitives.ml less more

	0	open QCheck2
	1	open Helpers
	2
	3	(** {1. Test primitives derivation} *)
	4
	5	(** {2. Tests} *)
	6
	7	type int' = int [@@deriving qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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 qcheck2]
	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/qcheck2/test_qualified_names.ml less more

	0	open QCheck2
	1	open Helpers
	2
	3	module type S = sig
	4	type t = int
	5
	6	val gen : int QCheck2.Gen.t
	7	end
	8
	9	module Q : S = struct
	10	type t = int [@@deriving qcheck2]
	11	end
	12
	13	module F (X : S) = struct
	14	type t = X.t [@@deriving qcheck2]
	15	end
	16
	17	module G = F (Q)
	18
	19	type t = Q.t [@@deriving qcheck2]
	20
	21	type u = G.t [@@deriving qcheck2]
	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	])]

+12

-0

test/ppx_deriving_qcheck/deriver/qcheck2/test_record.ml less more

	0	type t = {
	1	rec_types : string list;
	2	curr_types : string list;
	3	curr_type : string
	4	}
	5	[@@deriving qcheck2]
	6
	7	type color = Color of { red : float; green : float; blue : float }
	8	[@@deriving qcheck2]
	9
	10	(* TODO: use these types to test generated values inside records.
	11	For now, having these ensure the compilation *)

+78

-0

test/ppx_deriving_qcheck/deriver/qcheck2/test_recursive.ml less more

	0	open QCheck2
	1	open Helpers
	2
	3	type 'a tree = Leaf \| Node of 'a * 'a tree * 'a tree
	4	[@@deriving qcheck2]
	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 test_tree_ref () =
	31	let gen = Gen.int in
	32	test_compare ~msg:"gen tree <=> derivation tree"
	33	~eq:(eq_tree Format.pp_print_int)
	34	(gen_tree_ref gen) (gen_tree gen)
	35
	36	let test_leaf =
	37	Test.make
	38	~name:"gen_tree_sized 0 = Node (_, Leaf, Leaf)"
	39	(gen_tree_sized Gen.int 0)
	40	(function
	41	\| Leaf -> true
	42	\| Node (_, Leaf, Leaf) -> true
	43	\| _ -> false)
	44	\|>
	45	QCheck_alcotest.to_alcotest
	46
	47	(* A slight error has been found here:
	48	If the type is named `list` then `'a list` will be derived with the
	49	QCheck generator `list` instead of the `gen_list_sized`.
	50
	51	This could lead to a design choice:
	52	- do we allow overriding primitive types?
	53	- do we prioritize `Env.curr_types` over primitive types?
	54	*)
	55	type 'a my_list = Cons of 'a * 'a my_list \| Nil
	56	[@@deriving qcheck2]
	57
	58	let rec length = function
	59	\| Nil -> 0
	60	\| Cons (_, xs) -> 1 + length xs
	61
	62	let test_length =
	63	Test.make
	64	~name:"gen_list_sized n >>= fun l -> length l <= n"
	65	Gen.small_int
	66	(fun n ->
	67	let l = Gen.(generate1 (gen_my_list_sized Gen.int n)) in
	68	length l <= n)
	69	\|>
	70	QCheck_alcotest.to_alcotest
	71
	72	let () = Alcotest.run "Test_Recursive"
	73	[("Recursive",
	74	Alcotest.[
	75	test_case "test_tree_ref" `Quick test_tree_ref;
	76	test_leaf
	77	])]

+767

-0

test/ppx_deriving_qcheck/deriver/qcheck2/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_gens ~version:`QCheck2 ~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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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 = QCheck2.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	* QCheck2.map
	86	* (fun n -> Bytes.create n)
	87	* QCheck2.(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	QCheck2.Gen.map
	111	(fun (gen0, gen1) -> (gen0, gen1))
	112	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.Gen.int)];
	113	[%stri
	114	let gen =
	115	QCheck2.Gen.map
	116	(fun (gen0, gen1, gen2) -> (gen0, gen1, gen2))
	117	(QCheck2.Gen.triple QCheck2.Gen.int QCheck2.Gen.int QCheck2.Gen.int)];
	118	[%stri
	119	let gen =
	120	QCheck2.Gen.map
	121	(fun (gen0, gen1, gen2, gen3) -> (gen0, gen1, gen2, gen3))
	122	(QCheck2.Gen.quad
	123	QCheck2.Gen.int
	124	QCheck2.Gen.int
	125	QCheck2.Gen.int
	126	QCheck2.Gen.int)];
	127	[%stri
	128	let gen =
	129	QCheck2.Gen.map
	130	(fun ((gen0, gen1), (gen2, gen3, gen4)) ->
	131	(gen0, gen1, gen2, gen3, gen4))
	132	(QCheck2.Gen.pair
	133	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.Gen.int)
	134	(QCheck2.Gen.triple QCheck2.Gen.int QCheck2.Gen.int QCheck2.Gen.int))];
	135	[%stri
	136	let gen =
	137	QCheck2.Gen.map
	138	(fun ((gen0, gen1, gen2), (gen3, gen4, gen5)) ->
	139	(gen0, gen1, gen2, gen3, gen4, gen5))
	140	(QCheck2.Gen.pair
	141	(QCheck2.Gen.triple QCheck2.Gen.int QCheck2.Gen.int QCheck2.Gen.int)
	142	(QCheck2.Gen.triple QCheck2.Gen.int QCheck2.Gen.int QCheck2.Gen.int))];
	143	]
	144	in
	145
	146	check_eq ~expected ~actual "deriving tuples"
	147
	148	let test_option () =
	149	let expected = [ [%stri let gen = QCheck2.Gen.option QCheck2.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 = QCheck2.Gen.array QCheck2.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 = QCheck2.Gen.list QCheck2.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 = QCheck2.Gen.list gen_a];
	169	[%stri let gen gen_a = QCheck2.Gen.map (fun gen0 -> A gen0) gen_a];
	170	[%stri
	171	let gen gen_a gen_b =
	172	QCheck2.Gen.map
	173	(fun (gen0, gen1) -> A (gen0, gen1))
	174	(QCheck2.Gen.pair gen_a gen_b)];
	175	[%stri
	176	let gen gen_left gen_right =
	177	QCheck2.Gen.map
	178	(fun (gen0, gen1) -> (gen0, gen1))
	179	(QCheck2.Gen.pair gen_left gen_right)];
	180	[%stri
	181	let gen_int_tree = gen_tree QCheck2.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	QCheck2.Gen.frequency
	205	[
	206	(1, QCheck2.Gen.pure A);
	207	(1, QCheck2.Gen.pure B);
	208	(1, QCheck2.Gen.pure C);
	209	]];
	210	[%stri
	211	let gen_t' =
	212	QCheck2.Gen.frequency
	213	[
	214	(1, QCheck2.Gen.pure A);
	215	(1, QCheck2.Gen.pure B);
	216	(1, QCheck2.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	QCheck2.Gen.frequency
	233	[
	234	(1, QCheck2.Gen.map (fun gen0 -> Int gen0) SomeModule.gen);
	235	( 1,
	236	QCheck2.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 = QCheck2.Gen.map (fun gen0 -> A gen0) QCheck2.Gen.int];
	261	[%stri
	262	let gen =
	263	QCheck2.Gen.frequency
	264	[
	265	(1, QCheck2.Gen.map (fun gen0 -> B gen0) QCheck2.Gen.int);
	266	(1, QCheck2.Gen.map (fun gen0 -> C gen0) QCheck2.Gen.int);
	267	]];
	268	[%stri
	269	let gen =
	270	QCheck2.Gen.frequency
	271	[
	272	(1, QCheck2.Gen.map (fun gen0 -> X gen0) gen_t1);
	273	(1, QCheck2.Gen.map (fun gen0 -> Y gen0) gen_t2);
	274	(1, QCheck2.Gen.map (fun gen0 -> Z gen0) QCheck2.Gen.string);
	275	]];
	276	[%stri
	277	let gen =
	278	QCheck2.Gen.frequency
	279	[ (1, QCheck2.Gen.pure Left); (1, QCheck2.Gen.pure Right) ]];
	280	[%stri
	281	let gen =
	282	QCheck2.Gen.frequency
	283	[
	284	(1, QCheck2.Gen.map (fun gen0 -> Simple gen0) QCheck2.Gen.int);
	285	( 1,
	286	QCheck2.Gen.map
	287	(fun (gen0, gen1) -> Double (gen0, gen1))
	288	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.Gen.int) );
	289	( 1,
	290	QCheck2.Gen.map
	291	(fun (gen0, gen1, gen2) -> Triple (gen0, gen1, gen2))
	292	(QCheck2.Gen.triple
	293	QCheck2.Gen.int
	294	QCheck2.Gen.int
	295	QCheck2.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	QCheck2.Gen.map
	322	(fun (gen0, gen1) -> { a = gen0; b = gen1 })
	323	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.Gen.string)];
	324	[%stri
	325	let gen =
	326	QCheck2.Gen.map
	327	(fun (gen0, gen1) -> { a = gen0; b = gen1 })
	328	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.Gen.string)];
	329	[%stri
	330	let gen =
	331	QCheck2.Gen.frequency
	332	[
	333	(1, QCheck2.Gen.map (fun gen0 -> A gen0) gen_t');
	334	( 1,
	335	QCheck2.Gen.map
	336	(fun (gen0, gen1) -> B { left = gen0; right = gen1 })
	337	(QCheck2.Gen.pair QCheck2.Gen.int QCheck2.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	(QCheck2.Gen.frequency
	358	[
	359	(1, QCheck2.Gen.pure `A);
	360	(1, QCheck2.Gen.map (fun gen0 -> `B gen0) QCheck2.Gen.int);
	361	(1, QCheck2.Gen.map (fun gen0 -> `C gen0) QCheck2.Gen.string);
	362	]
	363	: t QCheck2.Gen.t)];
	364	[%stri
	365	let gen_t' =
	366	(QCheck2.Gen.frequency [ (1, QCheck2.Gen.pure `B); (1, gen) ]
	367	: t' QCheck2.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 -> QCheck2.Gen.pure Leaf
	387	\| _ ->
	388	QCheck2.Gen.frequency
	389	[
	390	(1, QCheck2.Gen.pure Leaf);
	391	( 1,
	392	QCheck2.Gen.map
	393	(fun (gen0, gen1, gen2) -> Node (gen0, gen1, gen2))
	394	(QCheck2.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 = QCheck2.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 -> QCheck2.Gen.map (fun gen0 -> Value gen0) QCheck2.Gen.int
	418	\| _ ->
	419	QCheck2.Gen.frequency
	420	[
	421	( 1,
	422	QCheck2.Gen.map (fun gen0 -> Value gen0) QCheck2.Gen.int
	423	);
	424	( 1,
	425	QCheck2.Gen.map
	426	(fun (gen0, gen1, gen2) -> If (gen0, gen1, gen2))
	427	(QCheck2.Gen.triple
	428	(gen_expr_sized (n / 2))
	429	(gen_expr_sized (n / 2))
	430	(gen_expr_sized (n / 2))) );
	431	( 1,
	432	QCheck2.Gen.map
	433	(fun (gen0, gen1) -> Eq (gen0, gen1))
	434	(QCheck2.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
	435	( 1,
	436	QCheck2.Gen.map
	437	(fun (gen0, gen1) -> Lt (gen0, gen1))
	438	(QCheck2.Gen.pair (gen_expr_sized (n / 2)) (gen_expr_sized (n / 2))) );
	439	]
	440	];
	441	[%stri
	442	let gen_expr = QCheck2.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	QCheck2.Gen.map
	463	(fun gen0 -> Node gen0)
	464	(QCheck2.Gen.map
	465	(fun (gen0, gen1) -> (gen0, gen1))
	466	(QCheck2.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 -> QCheck2.Gen.pure Nil
	471	\| _ ->
	472	QCheck2.Gen.frequency
	473	[
	474	(1, QCheck2.Gen.pure Nil);
	475	( 1,
	476	QCheck2.Gen.map
	477	(fun gen0 -> Cons gen0)
	478	(QCheck2.Gen.map
	479	(fun (gen0, gen1) -> (gen0, gen1))
	480	(QCheck2.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 = QCheck2.Gen.sized (gen_tree_sized gen_a)];
	486	[%stri let gen_forest gen_a = QCheck2.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	QCheck2.fun_nary
	505	QCheck2.Tuple.(
	506	QCheck2.Observable.int @-> QCheck2.Observable.int @-> o_nil)
	507	QCheck2.Gen.string];
	508	[%stri
	509	let gen =
	510	QCheck2.fun_nary
	511	QCheck2.Tuple.(
	512	QCheck2.Observable.float @-> QCheck2.Observable.float @-> o_nil)
	513	QCheck2.Gen.string
	514	];
	515	[%stri
	516	let gen =
	517	QCheck2.fun_nary
	518	QCheck2.Tuple.(
	519	QCheck2.Observable.string @-> QCheck2.Observable.string @-> o_nil)
	520	QCheck2.Gen.string
	521	];
	522	[%stri
	523	let gen =
	524	QCheck2.fun_nary
	525	QCheck2.Tuple.(
	526	QCheck2.Observable.bool @-> QCheck2.Observable.bool @-> o_nil)
	527	QCheck2.Gen.string
	528	];
	529	[%stri
	530	let gen =
	531	QCheck2.fun_nary
	532	QCheck2.Tuple.(
	533	QCheck2.Observable.char @-> QCheck2.Observable.char @-> o_nil)
	534	QCheck2.Gen.string
	535	];
	536	[%stri
	537	let gen =
	538	QCheck2.fun_nary
	539	QCheck2.Tuple.(QCheck2.Observable.unit @-> o_nil)
	540	QCheck2.Gen.string
	541	];
	542	]
	543	in
	544
	545	let actual =
	546	f'
	547	@@ extract'
	548	[
	549	[%stri type t = int -> int -> string];
	550	[%stri type t = float -> float -> string];
	551	[%stri type t = string -> string -> string];
	552	[%stri type t = bool -> bool -> string];
	553	[%stri type t = char -> char -> string];
	554	[%stri type t = unit -> string];
	555	]
	556	in
	557	check_eq ~expected ~actual "deriving fun primitives"
	558
	559	let test_fun_n () =
	560	let expected =
	561	[
	562	[%stri
	563	let gen =
	564	QCheck2.fun_nary
	565	QCheck2.Tuple.(
	566	QCheck2.Observable.bool @-> QCheck2.Observable.int
	567	@-> QCheck2.Observable.float @-> QCheck2.Observable.string
	568	@-> QCheck2.Observable.char @-> o_nil)
	569	QCheck2.Gen.unit
	570	];
	571	]
	572	in
	573	let actual =
	574	f @@ extract [%stri type t = bool -> int -> float -> string -> char -> unit]
	575	in
	576	check_eq ~expected ~actual "deriving fun n"
	577
	578	let test_fun_option () =
	579	let expected =
	580	[
	581	[%stri
	582	let gen =
	583	QCheck2.fun_nary
	584	QCheck2.Tuple.(
	585	QCheck2.Observable.option QCheck2.Observable.int @-> o_nil)
	586	QCheck2.Gen.unit
	587	];
	588	]
	589	in
	590	let actual = f @@ extract [%stri type t = int option -> unit] in
	591	check_eq ~expected ~actual "deriving fun option"
	592
	593	let test_fun_list () =
	594	let expected =
	595	[
	596	[%stri
	597	let gen =
	598	QCheck2.fun_nary
	599	QCheck2.Tuple.(
	600	QCheck2.Observable.list QCheck2.Observable.int @-> o_nil)
	601	QCheck2.Gen.unit
	602	];
	603	]
	604	in
	605	let actual = f @@ extract [%stri type t = int list -> unit] in
	606	check_eq ~expected ~actual "deriving fun list"
	607
	608	let test_fun_array () =
	609	let expected =
	610	[
	611	[%stri
	612	let gen =
	613	QCheck2.fun_nary
	614	QCheck2.Tuple.(
	615	QCheck2.Observable.array QCheck2.Observable.int @-> o_nil)
	616	QCheck2.Gen.unit
	617	];
	618	]
	619	in
	620	let actual = f @@ extract [%stri type t = int array -> unit] in
	621	check_eq ~expected ~actual "deriving fun array"
	622
	623	let test_fun_tuple () =
	624	let expected =
	625	[
	626	[%stri
	627	let gen =
	628	QCheck2.fun_nary
	629	QCheck2.Tuple.(
	630	QCheck2.Observable.pair QCheck2.Observable.int QCheck2.Observable.int
	631	@-> o_nil)
	632	QCheck2.Gen.unit
	633	];
	634	[%stri
	635	let gen =
	636	QCheck2.fun_nary
	637	QCheck2.Tuple.(
	638	QCheck2.Observable.triple
	639	QCheck2.Observable.int
	640	QCheck2.Observable.int
	641	QCheck2.Observable.int
	642	@-> o_nil)
	643	QCheck2.Gen.unit
	644	];
	645	[%stri
	646	let gen =
	647	QCheck2.fun_nary
	648	QCheck2.Tuple.(
	649	QCheck2.Observable.quad
	650	QCheck2.Observable.int
	651	QCheck2.Observable.int
	652	QCheck2.Observable.int
	653	QCheck2.Observable.int
	654	@-> o_nil)
	655	QCheck2.Gen.unit
	656	];
	657	]
	658	in
	659	let actual =
	660	f'
	661	@@ extract'
	662	[
	663	[%stri type t = int * int -> unit];
	664	[%stri type t = int * int * int -> unit];
	665	[%stri type t = int * int * int * int -> unit];
	666	]
	667	in
	668	check_eq ~expected ~actual "deriving fun tuple"
	669
	670	let test_weight_konstrs () =
	671	let expected =
	672	[
	673	[%stri
	674	let gen =
	675	QCheck2.Gen.frequency
	676	[
	677	(5, QCheck2.Gen.pure A);
	678	(6, QCheck2.Gen.pure B);
	679	(1, QCheck2.Gen.pure C);
	680	]];
	681	]
	682	in
	683	let actual =
	684	f @@ extract [%stri type t = A [@weight 5] \| B [@weight 6] \| C]
	685	in
	686	check_eq ~expected ~actual "deriving weight konstrs"
	687
	688	(* Regression test: https://github.com/c-cube/qcheck/issues/187 *)
	689	let test_recursive_poly_variant () =
	690	let expected =
	691	[
	692	[%stri
	693	let rec gen_tree_sized gen_a n =
	694	(match n with
	695	\| 0 -> QCheck2.Gen.map (fun gen0 -> `Leaf gen0) gen_a
	696	\| _ ->
	697	QCheck2.Gen.frequency
	698	[
	699	( 1,
	700	QCheck2.Gen.map (fun gen0 -> `Leaf gen0) gen_a
	701	);
	702	( 1,
	703	QCheck2.Gen.map
	704	(fun gen0 -> `Node gen0)
	705	(QCheck2.Gen.map
	706	(fun (gen0, gen1) -> (gen0, gen1))
	707	(QCheck2.Gen.pair
	708	((gen_tree_sized gen_a) (n / 2))
	709	((gen_tree_sized gen_a) (n / 2))))
	710	);
	711	]
	712	: tree QCheck2.Gen.t)];
	713	[%stri
	714	let gen_tree gen_a = QCheck2.Gen.sized (gen_tree_sized gen_a)
	715	]
	716	]
	717	in
	718	let actual =
	719	f @@ extract [%stri type 'a tree = [ `Leaf of 'a \| `Node of 'a tree * 'a tree ]]
	720	in
	721	check_eq ~expected ~actual "deriving recursive polymorphic variants"
	722
	723	let () =
	724	Alcotest.(
	725	run
	726	"ppx_deriving_qcheck tests"
	727	[
	728	( "deriving generator good",
	729	[
	730	test_case "deriving int" `Quick test_int;
	731	test_case "deriving float" `Quick test_float;
	732	test_case "deriving char" `Quick test_char;
	733	test_case "deriving string" `Quick test_string;
	734	test_case "deriving unit" `Quick test_unit;
	735	test_case "deriving bool" `Quick test_bool;
	736	test_case "deriving int32" `Quick test_int32;
	737	test_case "deriving int32'" `Quick test_int32';
	738	test_case "deriving int64" `Quick test_int64;
	739	test_case "deriving int64'" `Quick test_int64';
	740	(* test_case "deriving bytes" `Quick test_bytes; *)
	741	test_case "deriving tuple" `Quick test_tuple;
	742	test_case "deriving option" `Quick test_option;
	743	test_case "deriving array" `Quick test_array;
	744	test_case "deriving list" `Quick test_list;
	745	test_case "deriving constructors" `Quick test_konstr;
	746	test_case "deriving dependencies" `Quick test_dependencies;
	747	test_case "deriving record" `Quick test_record;
	748	test_case "deriving equal" `Quick test_equal;
	749	test_case "deriving tree like" `Quick test_tree;
	750	test_case "deriving expr like" `Quick test_expr;
	751	test_case "deriving alpha" `Quick test_alpha;
	752	test_case "deriving variant" `Quick test_variant;
	753	test_case "deriving weight constructors" `Quick test_weight_konstrs;
	754	test_case "deriving forest" `Quick test_forest;
	755	test_case "deriving fun primitives" `Quick test_fun_primitives;
	756	test_case "deriving fun option" `Quick test_fun_option;
	757	test_case "deriving fun array" `Quick test_fun_array;
	758	test_case "deriving fun list" `Quick test_fun_list;
	759	test_case "deriving fun n" `Quick test_fun_n;
	760	test_case "deriving fun tuple" `Quick test_fun_tuple;
	761	test_case
	762	"deriving rec poly variants"
	763	`Quick
	764	test_recursive_poly_variant;
	765	] );
	766	])

+23

-0

test/ppx_deriving_qcheck/deriver/qcheck2/test_tuple.ml less more

	0	type tup2 = int * int
	1	[@@deriving qcheck2]
	2
	3	type tup3 = int * int * int
	4	[@@deriving qcheck2]
	5
	6	type tup4 = int * int * int * int
	7	[@@deriving qcheck2]
	8
	9	type tup5 = int * int * int * int * int
	10	[@@deriving qcheck2]
	11
	12	type tup6 = int * int * int * int * int * int
	13	[@@deriving qcheck2]
	14
	15	type tup7 = int * int * int * int * int * int * int
	16	[@@deriving qcheck2]
	17
	18	type tup8 = int * int * int * int * int * int * int * int
	19	[@@deriving qcheck2]
	20
	21	(* TODO: use these types to test generated values inside tuples.
	22	For now, having these ensure the compilation *)

+81

-0

test/ppx_deriving_qcheck/deriver/qcheck2/test_variants.ml less more

	0	open QCheck2
	1	open Helpers
	2
	3	(** {1. Test variants and polymorphic variants derivation} *)
	4
	5	(** {2. Variants} *)
	6
	7	type colors = Red \| Green \| Blue [@@deriving qcheck2]
	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 qcheck2]
	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 qcheck2]
	46
	47	let test_weight =
	48	Test.make ~name:"gen_letters always produces B"
	49	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 qcheck2]
	61
	62	let test_weight_poly =
	63	Test.make ~name:"gen_poly_letters always produces B"
	64	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	])]

-89

~~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.option <=> deriving option"
53		~eq:Alcotest.(option int)
54		(Gen.option 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

~~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

~~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

~~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

~~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.option 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

~~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

~~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		])]