2903

Committed 15 Nov 2024 01:59PM UTC coverage: 36.723% (-25.0%) from 61.682%

Build # 2903

Build Type

Pull #16342

buildkite

Committed by

dkijania

Commit Message

Merge branch 'dkijania/remove_publish_job_from_pr_comp' into dkijania/remove_publish_job_from_pr_dev

Pull Request Pull Request #16342: [DEV] Publish debians only on nightly and stable

Run Details

15 of 40 new or added lines in 14 files covered. (37.5%)

15175 existing lines in 340 files now uncovered.

24554 of 66863 relevant lines covered (36.72%)

20704.91 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

14.58

/src/lib/quickcheck_lib/quickcheck_lib.ml

1	(* quickcheck_lib.ml *)
2		21✔
3	open Core_kernel
4	open Quickcheck.Generator
5	open Quickcheck.Let_syntax
6
7	let of_array array = Quickcheck.Generator.of_list @@ Array.to_list array	10,003✔
8
9	let rec map_gens ls ~f =
UNCOV 10	match ls with	×
UNCOV 11	\| [] ->	×
12	return []
UNCOV 13	\| h :: t ->	×
UNCOV 14	let%bind h' = f h in	×
UNCOV 15	let%map t' = map_gens t ~f in	×
UNCOV 16	h' :: t'	×
17
UNCOV 18	let replicate_gen g n = map_gens (List.init n ~f:Fn.id) ~f:(Fn.const g)	×
19
20	let init_gen ~f n =
UNCOV 21	let rec go : 'a list -> int -> 'a list Quickcheck.Generator.t =	×
22	fun xs n' ->
UNCOV 23	if n' < n then f n' >>= fun x -> go (x :: xs) (n' + 1)	×
UNCOV 24	else return @@ List.rev xs	×
25	in
26	go [] 0
27
UNCOV 28	let init_gen_array ~f n = map ~f:Array.of_list @@ init_gen ~f n	×
29
30	let gen_pair g =
31	let%map a = g and b = g in
32	(a, b)	10,000✔
33
34	let shuffle_arr_inplace arr =
35	(* Fisher-Yates shuffle, you need fast swaps for decent performance, so we
36	want an array if we're not getting unnecessarily fancy. *)
UNCOV 37	let rec go n =	×
UNCOV 38	if n < Array.length arr then (	×
UNCOV 39	let%bind swap_idx = Int.gen_uniform_incl n (Array.length arr - 1) in	×
UNCOV 40	Array.swap arr n swap_idx ;	×
UNCOV 41	go (n + 1) )	×
UNCOV 42	else return arr	×
43	in
44	go 0
45
46	let shuffle_arr arr = shuffle_arr_inplace @@ Array.copy arr	×
47
48	let shuffle list =
UNCOV 49	Array.of_list list \|> shuffle_arr_inplace \|> map ~f:Array.to_list	×
50
51	(* Generate a list with a Dirichlet distribution, used for coming up with random
52	splits of a quantity. Symmetric Dirichlet distribution with alpha = 1.
53	*)
54	let gen_symm_dirichlet : int -> float list Quickcheck.Generator.t =
55	fun n ->
UNCOV 56	let open Quickcheck.Generator.Let_syntax in	×
57	let%map gammas =
UNCOV 58	map_gens	×
UNCOV 59	(List.init n ~f:(Fn.const ()))	×
60	~f:(fun _ ->
UNCOV 61	let open Quickcheck.Generator.Let_syntax in	×
62	(* technically this should be (0, 1] and not (0, 1) but I expect it
63	doesn't matter for our purposes. *)
UNCOV 64	let%map uniform = Float.gen_uniform_excl 0. 1. in	×
UNCOV 65	Float.log uniform )	×
66	in
UNCOV 67	let sum = List.fold gammas ~init:0. ~f:(fun x y -> x +. y) in	×
UNCOV 68	List.map gammas ~f:(fun gamma -> gamma /. sum)	×
69
70	module type Int_s = sig
71	type t
72
73	val zero : t
74
75	val ( + ) : t -> t -> t
76
77	val ( - ) : t -> t -> t
78
79	val ( > ) : t -> t -> bool
80
81	val of_int : int -> t
82
83	val to_int : t -> int
84	end
85
86	let gen_division_generic (type t) (module M : Int_s with type t = t) (n : t)
87	(k : int) : M.t list Quickcheck.Generator.t =
UNCOV 88	if k = 0 then Quickcheck.Generator.return []	×
89	else
UNCOV 90	let open Quickcheck.Generator.Let_syntax in	×
91	(* Using a symmetric Dirichlet distribution with concentration parameter 1
92	defined above gives a distribution with uniform probability density over
93	all possible splits of the quantity. See the Wikipedia article for some
94	more detail: https://en.wikipedia.org/wiki/Dirichlet_distribution,
95	particularly the sections about the flat Dirichlet distribution and
96	string cutting.
97	*)
UNCOV 98	let%bind dirichlet = gen_symm_dirichlet k in	×
UNCOV 99	let n_float = Float.of_int @@ M.to_int n in	×
UNCOV 100	let float_to_mt : float -> t =	×
101	fun fl ->
UNCOV 102	match Float.iround_down fl with	×
UNCOV 103	\| Some int ->	×
104	M.of_int int
105	\| None ->	×
106	failwith "gen_division_generic: out of range"
107	in
UNCOV 108	let res = List.map dirichlet ~f:(fun x -> float_to_mt @@ (x *. n_float)) in	×
UNCOV 109	let total = List.fold res ~f:M.( + ) ~init:M.zero in	×
UNCOV 110	return	×
111	( match res with
112	\| [] ->	×
113	failwith
114	"empty result list in gen_symm_dirichlet, this should be \
115	impossible. "
UNCOV 116	\| head :: rest ->	×
117	(* Going through floating point land may have caused some rounding error. We
118	tack it onto the first result so that the sum of the output is equal to n.
119	*)
UNCOV 120	if M.( > ) n total then M.(head + (n - total)) :: rest	×
UNCOV 121	else M.(head - (total - n)) :: rest )	×
122
123	let gen_division = gen_division_generic (module Int)	21✔
124
125	let gen_division_currency =
126	gen_division_generic	21✔
127	( module struct
128	include Currency.Amount
129
UNCOV 130	let ( + ) a b = Option.value_exn (a + b)	×
131
UNCOV 132	let ( - ) a b = Option.value_exn (a - b)	×
133
134	let of_int = of_nanomina_int_exn
135
136	let to_int = to_nanomina_int
137	end )
138
139	let imperative_fixed_point root ~f =
140	let%map f' = fixed_point f in	20✔
141	f' root	20✔
142
UNCOV 143	let gen_imperative_rose_tree ?(p = 0.75) (root_gen : 'a t)	×
144	(node_gen : ('a -> 'a) t) =
145	let%bind root = root_gen in
UNCOV 146	imperative_fixed_point root ~f:(fun self ->	×
147	match%bind size with
UNCOV 148	\| 0 ->	×
UNCOV 149	return (fun parent -> Rose_tree.T (parent, []))	×
UNCOV 150	\| n ->	×
UNCOV 151	let%bind fork_count = geometric ~p 1 >>\| Int.max n in	×
UNCOV 152	let%bind fork_sizes = gen_division n fork_count in	×
UNCOV 153	let positive_fork_sizes =	×
UNCOV 154	List.filter fork_sizes ~f:(fun s -> s > 0)	×
155	in
156	let%map forks =
UNCOV 157	map_gens positive_fork_sizes ~f:(fun s ->	×
UNCOV 158	tuple2 node_gen (with_size ~size:(s - 1) self) )	×
159	in
160	fun parent ->
UNCOV 161	Rose_tree.T	×
UNCOV 162	(parent, List.map forks ~f:(fun (this, f) -> f (this parent))) )	×
163
164	let gen_imperative_ktree ?(p = 0.75) (root_gen : 'a t) (node_gen : ('a -> 'a) t)	×
165	=
166	let%bind root = root_gen in
167	imperative_fixed_point root ~f:(fun self ->	×
168	match%bind size with
169	\| 0 ->	×
170	return (fun _ -> [])	×
171	(* this case is optional but more effecient *)
172	\| 1 ->	×
173	let%map this = node_gen in
174	fun parent -> [ this parent ]	×
175	\| n ->	×
176	let%bind this = node_gen in
177	let%bind fork_count = geometric ~p 1 >>\| Int.max n in	×
178	let%bind fork_sizes = gen_division (n - 1) fork_count in	×
179	let%map forks =
180	map_gens fork_sizes ~f:(fun s -> with_size ~size:s self)	×
181	in
182	fun parent ->
183	let x = this parent in	×
184	x :: List.bind forks ~f:(fun f -> f x) )	×
185
186	let gen_imperative_list (root_gen : 'a t) (node_gen : ('a -> 'a) t) =
187	let%bind root = root_gen in
188	imperative_fixed_point root ~f:(fun self ->	20✔
189	match%bind size with
190	\| 0 ->	20✔
191	return (fun _ -> [])	20✔
192	\| n ->	200✔
193	let%bind this = node_gen in
194	let%map f = with_size ~size:(n - 1) self in	200✔
195	fun parent -> parent :: f (this parent) )	200✔
196
197	let%test_module "Quickcheck lib tests" =
198	( module struct
199	let%test_unit "gen_imperative_list" =
UNCOV 200	let increment = ( + ) 2 in	×
201	let root = 1 in
202	let root_gen = return root in
UNCOV 203	let gen =	×
UNCOV 204	Int.gen_incl 2 100	×
205	>>= fun size ->
UNCOV 206	Quickcheck.Generator.with_size ~size	×
UNCOV 207	(gen_imperative_list root_gen (return increment))	×
208	in
UNCOV 209	Quickcheck.test gen ~f:(fun list ->	×
UNCOV 210	match list with	×
211	\| [] ->	×
212	failwith "We assume that our list has at least one element"
UNCOV 213	\| x :: xs ->	×
UNCOV 214	assert (x = root) ;	×
215	let result =
216	List.fold_result xs ~init:x ~f:(fun elem next_elem ->
UNCOV 217	if next_elem = increment elem then Result.return next_elem	×
218	else
219	Or_error.errorf	×
220	!"elements do not add up correctly %d %d"
221	elem next_elem )
222	in
UNCOV 223	assert (Result.is_ok result) )	×
224	end )	21✔

MinaProtocol / mina / 2903

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous