Commit 2574c45cb8c0effdede73870e7a1624d0d2cafda - ocaml-qcheck

New upstream version 0.13 Stephane Glondu authored 3 years ago Stéphane Glondu committed 3 years ago

10 changed file(s) with 172 addition(s) and 30 deletion(s). Raw diff Collapse all Expand all

-0

CHANGELOG.md less more

0	0	# Changes
	1
	2	## 0.13
	3
	4	- make counter private
	5	- Add debug shrinking log
	6	- fix: small fix related to stdlib/pervasives
	7	- feat: add flatten combinators in `gen`
1	8
2	9	## 0.12
3	10

-1

Makefile less more

19	19	@dune exec example/ounit/QCheck_ounit_test.exe
20	20
21	21	example-runner:
22		@dune exec example/QCheck_runner_test.exe
	22	@dune exec example/QCheck_runner_test.exe -- --debug-shrink=log.tmp
23	23
24	24	example-alcotest:
25	25	@dune exec example/alcotest/QCheck_alcotest_test.exe

-1

qcheck-alcotest.opam less more

3	3	homepage: "https://github.com/c-cube/qcheck/"
4	4	synopsis: "Alcotest backend for qcheck"
5	5	doc: ["http://c-cube.github.io/qcheck/"]
6		version: "0.12"
	6	version: "0.13"
7	7	tags: [
8	8	"test"
9	9	"quickcheck"

-1

qcheck-core.opam less more

3	3	homepage: "https://github.com/c-cube/qcheck/"
4	4	synopsis: "Core qcheck library"
5	5	doc: ["http://c-cube.github.io/qcheck/"]
6		version: "0.12"
	6	version: "0.13"
7	7	tags: [
8	8	"test"
9	9	"property"

-1

qcheck-ounit.opam less more

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

-1

qcheck.opam less more

3	3	synopsis: "Compatibility package for qcheck"
4	4	homepage: "https://github.com/c-cube/qcheck/"
5	5	doc: ["http://c-cube.github.io/qcheck/"]
6		version: "0.12"
	6	version: "0.13"
7	7	tags: [
8	8	"test"
9	9	"property"

+15

-3

src/core/QCheck.ml less more

5	5
6	6	(** {1 Quickcheck inspired property-based testing} *)
7	7
	8	let poly_compare=compare
8	9	open Printf
9	10
10	11	module RS = Random.State

197	198	let array gen st = array_size nat gen st
198	199	let array_repeat n g = array_size (return n) g
199	200
	201	let flatten_l l st = List.map (fun f->f st) l
	202	let flatten_a a st = Array.map (fun f->f st) a
	203	let flatten_opt o st =
	204	match o with
	205	\| None -> None
	206	\| Some f -> Some (f st)
	207	let flatten_res r st =
	208	match r with
	209	\| Ok f -> Ok (f st)
	210	\| Error e -> Error e
	211
200	212	let shuffle_a a st =
201	213	for i = Array.length a-1 downto 1 do
202	214	let j = Random.State.int st (i+1) in

216	228	(float_bound_inclusive 1. st ** (1. /. fl_w), v)
217	229	in
218	230	let samples = List.rev_map sample l in
219		List.sort (fun (w1, _) (w2, _) -> compare w1 w2) samples \|> List.rev_map snd
	231	List.sort (fun (w1, _) (w2, _) -> poly_compare w1 w2) samples \|> List.rev_map snd
220	232
221	233	let pair g1 g2 st = (g1 st, g2 st)
222	234

1168	1180	(* all counter-examples in [l] have same size according to [small],
1169	1181	so we just compare to the first one, and we enforce
1170	1182	the invariant *)
1171		begin match Pervasives.compare (small instance) (small c_ex'.instance) with
	1183	begin match poly_compare (small instance) (small c_ex'.instance) with
1172	1184	\| 0 -> res.state <- Failed {instances=c_ex :: l} (* same size: add [c_ex] to [l] *)
1173	1185	\| n when n<0 -> res.state <- Failed {instances=[c_ex]} (* drop [l] *)
1174	1186	\| _ -> () (* drop [c_ex], not small enough *)

1571	1583	let median = ref 0 in
1572	1584	let median_num = ref 0 in (* how many values have we seen yet? once >= !n/2 we set median *)
1573	1585	(Hashtbl.fold (fun i cnt acc -> (i,cnt)::acc) tbl [])
1574		\|> List.sort (fun (i,_) (j,_) -> compare i j)
	1586	\|> List.sort (fun (i,_) (j,_) -> poly_compare i j)
1575	1587	\|> List.iter
1576	1588	(fun (i,cnt) ->
1577	1589	if !median_num < !num/2 then (

+18

-2

src/core/QCheck.mli less more

164	164
165	165	val (<$>) : ('a -> 'b) -> 'a t -> 'b t
166	166	(** An infix synonym for {!map}
167		@since NEXT_RELEASE *)
	167	@since 0.13 *)
168	168
169	169	val oneof : 'a t list -> 'a t
170	170	(** Constructs a generator that selects among a given list of generators. *)

321	321	val char_range : char -> char -> char t
322	322	(** Generates chars between the two bounds, inclusive.
323	323	Example: [char_range 'a' 'z'] for all lower case ascii letters.
324		@since NEXT_RELEASE *)
	324	@since 0.13 *)
325	325
326	326	val string_size : ?gen:char t -> int t -> string t
327	327	(** Builds a string generator from a (non-negative) size generator.

348	348	val small_list : 'a t -> 'a list t
349	349	(** Generates lists of small size (see {!small_nat}).
350	350	@since 0.5.3 *)
	351
	352	val flatten_l : 'a t list -> 'a list t
	353	(** Generate a list of elements from individual generators
	354	@since 0.13 *)
	355
	356	val flatten_a : 'a t array -> 'a array t
	357	(** Generate an array of elements from individual generators
	358	@since 0.13 *)
	359
	360	val flatten_opt : 'a t option -> 'a option t
	361	(** Generate an option from an optional generator
	362	@since 0.13 *)
	363
	364	val flatten_res : ('a t, 'e) result -> ('a,'e) result t
	365	(** Generate a result from [Ok g], an error from [Error e]
	366	@since 0.13 *)
351	367
352	368	val small_array : 'a t -> 'a array t
353	369	(** Generates arrays of small size (see {!small_nat}).

+92

-20

src/runner/QCheck_base_runner.ml less more

93	93	let r = ref false in
94	94	(fun () -> !r), (fun b -> r := b)
95	95
	96	let debug_shrink, set_debug_shrink =
	97	let r = ref None in
	98	(fun () -> !r), (fun s -> r := Some (open_out s))
	99
	100	let debug_shrink_list, set_debug_shrink_list =
	101	let r = ref [] in
	102	(fun () -> !r), (fun b -> r := b :: !r)
	103
96	104	module Raw = struct
97	105	type ('b,'c) printer = {
98	106	info: 'a. ('a,'b,'c,unit) format4 -> 'a;

107	115	cli_rand : Random.State.t;
108	116	cli_slow_test : int; (* how many slow tests to display? *)
109	117	cli_colors: bool;
	118	cli_debug_shrink : out_channel option;
	119	cli_debug_shrink_list : string list;
110	120	}
111	121
112	122	(* main callback for individual tests

164	174	; "--seed", Arg.Set_int seed, " set random seed (to repeat tests)"
165	175	; "--long", Arg.Unit set_long_tests, " run long tests"
166	176	; "-bt", Arg.Unit set_backtraces, " enable backtraces"
	177	; "--debug-shrink", Arg.String set_debug_shrink, " enable shrinking debug to <file>"
	178	; "--debug-shrink-list", Arg.String set_debug_shrink_list, " filter test to debug shrinking on"
167	179	]
168	180	) in
169	181	Arg.parse_argv argv options (fun _ ->()) "run qtest suite";
170	182	let cli_rand = setup_random_state_ () in
171	183	{ cli_verbose=verbose(); cli_long_tests=long_tests(); cli_rand;
172	184	cli_print_list= !print_list; cli_slow_test= !slow;
173		cli_colors= !colors; }
	185	cli_colors= !colors; cli_debug_shrink = debug_shrink();
	186	cli_debug_shrink_list = debug_shrink_list(); }
174	187	end
175	188
176	189	open Raw

188	201	type res =
189	202	\| Res : 'a QCheck.Test.cell * 'a QCheck.TestResult.t -> res
190	203
	204	type handler = {
	205	handler : 'a. 'a QCheck.Test.handler;
	206	}
	207
	208	type handler_gen =
	209	colors:bool ->
	210	debug_shrink:(out_channel option) ->
	211	debug_shrink_list:(string list) ->
	212	size:int -> out:out_channel -> verbose:bool -> counter -> handler
	213
191	214	let pp_counter ~size out c =
192	215	let t = Unix.gettimeofday () -. c.start in
193	216	Printf.fprintf out "%d %d %d %d / %*d %7.1fs"
194	217	size c.gen size c.errored size c.failed
195	218	size c.passed size c.expected t
196	219
197		let handler ~size ~out ~verbose c name _ r =
198		let st = function
199		\| QCheck.Test.Generating -> "generating"
200		\| QCheck.Test.Collecting _ -> "collecting"
201		\| QCheck.Test.Testing _ -> " testing"
202		\| QCheck.Test.Shrunk (i, _) ->
203		Printf.sprintf "shrinking: %4d" i
204		\| QCheck.Test.Shrinking (i, j, _) ->
205		Printf.sprintf "shrinking: %4d.%04d" i j
	220	let debug_shrinking_counter_example cell out x =
	221	match (QCheck.Test.get_arbitrary cell).QCheck.print with
	222	\| None -> Printf.fprintf out "<no printer provided>"
	223	\| Some print -> Printf.fprintf out "%s" (print x)
	224
	225	let debug_shrinking_size cell out x =
	226	match (QCheck.Test.get_arbitrary cell).QCheck.small with
	227	\| None -> ()
	228	\| Some f -> Printf.fprintf out ", size %d" (f x)
	229
	230	let debug_shrinking_choices_aux ~colors out name i cell x =
	231	Printf.fprintf out "\n~~~ %a %s\n\n"
	232	(Color.pp_str_c ~colors `Cyan) "Shrink" (String.make 69 '~');
	233	Printf.fprintf out
	234	"Test %s sucessfully shrunk counter example (step %d%a) to:\n\n%a\n%!"
	235	name i
	236	(debug_shrinking_size cell) x
	237	(debug_shrinking_counter_example cell) x
	238
	239	let debug_shrinking_choices
	240	~colors ~debug_shrink ~debug_shrink_list name cell i x =
	241	match debug_shrink with
	242	\| None -> ()
	243	\| Some out ->
	244	begin match debug_shrink_list with
	245	\| [] ->
	246	debug_shrinking_choices_aux ~colors out name i cell x
	247	\| l when List.mem name l ->
	248	debug_shrinking_choices_aux ~colors out name i cell x
	249	\| _ -> ()
	250	end
	251
	252
	253	let default_handler
	254	~colors ~debug_shrink ~debug_shrink_list
	255	~size ~out ~verbose c =
	256	let handler name cell r =
	257	let st = function
	258	\| QCheck.Test.Generating -> "generating"
	259	\| QCheck.Test.Collecting _ -> "collecting"
	260	\| QCheck.Test.Testing _ -> " testing"
	261	\| QCheck.Test.Shrunk (i, _) ->
	262	Printf.sprintf "shrinking: %4d" i
	263	\| QCheck.Test.Shrinking (i, j, _) ->
	264	Printf.sprintf "shrinking: %4d.%04d" i j
	265	in
	266	(* debug shrinking choices *)
	267	begin match r with
	268	\| QCheck.Test.Shrunk (i, x) ->
	269	debug_shrinking_choices
	270	~colors ~debug_shrink ~debug_shrink_list name cell i x
	271	\| _ ->
	272	()
	273	end;
	274	(* use timestamps for rate-limiting *)
	275	let now=Unix.gettimeofday() in
	276	if verbose && now -. !last_msg > get_time_between_msg () then (
	277	last_msg := now;
	278	Printf.fprintf out "%s[ ] %a %s (%s)%!"
	279	Color.reset_line (pp_counter ~size) c name (st r)
	280	)
206	281	in
207		(* use timestamps for rate-limiting *)
208		let now=Unix.gettimeofday() in
209		if verbose && now -. !last_msg > get_time_between_msg () then (
210		last_msg := now;
211		Printf.fprintf out "%s[ ] %a %s (%s)%!"
212		Color.reset_line (pp_counter ~size) c name (st r)
213		)
214
	282	{ handler; }
215	283
216	284	let step ~size ~out ~verbose c name _ _ r =
217	285	let aux = function

308	376	print_messages ~colors out cell c_ex.QCheck.TestResult.msg_l
309	377
310	378	let run_tests
311		?(colors=true) ?(verbose=verbose()) ?(long=long_tests()) ?(out=stdout) ?(rand=random_state()) l =
	379	?(handler=default_handler)
	380	?(colors=true) ?(verbose=verbose()) ?(long=long_tests())
	381	?(debug_shrink=debug_shrink()) ?(debug_shrink_list=debug_shrink_list())
	382	?(out=stdout) ?(rand=random_state()) l =
312	383	let module T = QCheck.Test in
313	384	let module R = QCheck.TestResult in
314	385	let pp_color = Color.pp_str_c ~bold:true ~colors in

330	401	Printf.fprintf out "%s[ ] %a %s%!"
331	402	Color.reset_line (pp_counter ~size) c (T.get_name cell);
332	403	let r = QCheck.Test.check_cell ~long ~rand
333		~handler:(handler ~size ~out ~verbose c)
	404	~handler:(handler ~colors ~debug_shrink ~debug_shrink_list
	405	~size ~out ~verbose c).handler
334	406	~step:(step ~size ~out ~verbose c)
335	407	~call:(callback ~size ~out ~verbose ~colors c)
336	408	cell

+35

-0

src/runner/QCheck_base_runner.mli less more

57	57	(** Set the minimum tiem between messages.
58	58	@since 0.9 *)
59	59
	60
	61	(** {2 Event handlers} *)
	62
	63	type counter = private {
	64	start : float;
	65	expected : int;
	66	mutable gen : int;
	67	mutable passed : int;
	68	mutable failed : int;
	69	mutable errored : int;
	70	}
	71	(** The type of counter used to keep tracks of the events received for a given
	72	test cell. *)
	73
	74	type handler = {
	75	handler : 'a. 'a QCheck.Test.handler;
	76	}
	77	(** A type to represent polymorphic-enough handlers for test cells. *)
	78
	79	type handler_gen =
	80	colors:bool ->
	81	debug_shrink:(out_channel option) ->
	82	debug_shrink_list:(string list) ->
	83	size:int -> out:out_channel -> verbose:bool -> counter -> handler
	84	(** An alias type to a generator of handlers for test cells. *)
	85
	86	val default_handler : handler_gen
	87	(** The default handler used. *)
	88
	89
60	90	(** {2 Run a Suite of Tests and Get Results} *)
61	91
62	92	val run_tests :
	93	?handler:handler_gen ->
63	94	?colors:bool -> ?verbose:bool -> ?long:bool ->
	95	?debug_shrink:(out_channel option) ->
	96	?debug_shrink_list:(string list) ->
64	97	?out:out_channel -> ?rand:Random.State.t ->
65	98	QCheck.Test.t list -> int
66	99	(** Run a suite of tests, and print its results. This is an heritage from

163	196	cli_rand : Random.State.t;
164	197	cli_slow_test : int; (* how many slow tests to display? *)
165	198	cli_colors: bool;
	199	cli_debug_shrink : out_channel option;
	200	cli_debug_shrink_list : string list;
166	201	}
167	202
168	203	val parse_cli : full_options:bool -> string array -> cli_args