2863

Committed 05 Nov 2024 06:20PM UTC coverage: 30.754% (-16.6%) from 47.311%

Build # 2863

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #16296 from MinaProtocol/dkijania/more_multi_jobs

more multi jobs in CI

Run Details

20276 of 65930 relevant lines covered (30.75%)

8631.7 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

(* quickcheck_lib.ml *)

open Core_kernel
open Quickcheck.Generator
open Quickcheck.Let_syntax

let of_array array = Quickcheck.Generator.of_list @@ Array.to_list array

let rec map_gens ls ~f =
  match ls with
  | [] ->
      return []
  | h :: t ->
      let%bind h' = f h in
      let%map t' = map_gens t ~f in
      h' :: t'

let replicate_gen g n = map_gens (List.init n ~f:Fn.id) ~f:(Fn.const g)

let init_gen ~f n =
  let rec go : 'a list -> int -> 'a list Quickcheck.Generator.t =
   fun xs n' ->
    if n' < n then f n' >>= fun x -> go (x :: xs) (n' + 1)
    else return @@ List.rev xs
  in
  go [] 0

let init_gen_array ~f n = map ~f:Array.of_list @@ init_gen ~f n

let gen_pair g =
  let%map a = g and b = g in
  (a, b)

let shuffle_arr_inplace arr =
  (* Fisher-Yates shuffle, you need fast swaps for decent performance, so we
     want an array if we're not getting unnecessarily fancy. *)
  let rec go n =
    if n < Array.length arr then (
      let%bind swap_idx = Int.gen_uniform_incl n (Array.length arr - 1) in
      Array.swap arr n swap_idx ;
      go (n + 1) )
    else return arr
  in
  go 0

let shuffle_arr arr = shuffle_arr_inplace @@ Array.copy arr

let shuffle list =
  Array.of_list list |> shuffle_arr_inplace |> map ~f:Array.to_list

(* Generate a list with a Dirichlet distribution, used for coming up with random
   splits of a quantity. Symmetric Dirichlet distribution with alpha = 1.
*)
let gen_symm_dirichlet : int -> float list Quickcheck.Generator.t =
 fun n ->
  let open Quickcheck.Generator.Let_syntax in
  let%map gammas =
    map_gens
      (List.init n ~f:(Fn.const ()))
      ~f:(fun _ ->
        let open Quickcheck.Generator.Let_syntax in
        (* technically this should be (0, 1] and not (0, 1) but I expect it
           doesn't matter for our purposes. *)
        let%map uniform = Float.gen_uniform_excl 0. 1. in
        Float.log uniform )
  in
  let sum = List.fold gammas ~init:0. ~f:(fun x y -> x +. y) in
  List.map gammas ~f:(fun gamma -> gamma /. sum)

module type Int_s = sig
  type t

  val zero : t

  val ( + ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( > ) : t -> t -> bool

  val of_int : int -> t

  val to_int : t -> int
end

let gen_division_generic (type t) (module M : Int_s with type t = t) (n : t)
    (k : int) : M.t list Quickcheck.Generator.t =
  if k = 0 then Quickcheck.Generator.return []
  else
    let open Quickcheck.Generator.Let_syntax in
    (* Using a symmetric Dirichlet distribution with concentration parameter 1
       defined above gives a distribution with uniform probability density over
       all possible splits of the quantity. See the Wikipedia article for some
       more detail: https://en.wikipedia.org/wiki/Dirichlet_distribution,
       particularly the sections about the flat Dirichlet distribution and
       string cutting.
    *)
    let%bind dirichlet = gen_symm_dirichlet k in
    let n_float = Float.of_int @@ M.to_int n in
    let float_to_mt : float -> t =
     fun fl ->
      match Float.iround_down fl with
      | Some int ->
          M.of_int int
      | None ->
          failwith "gen_division_generic: out of range"
    in
    let res = List.map dirichlet ~f:(fun x -> float_to_mt @@ (x *. n_float)) in
    let total = List.fold res ~f:M.( + ) ~init:M.zero in
    return
      ( match res with
      | [] ->
          failwith
            "empty result list in gen_symm_dirichlet, this should be \
             impossible. "
      | head :: rest ->
          (* Going through floating point land may have caused some rounding error. We
             tack it onto the first result so that the sum of the output is equal to n.
          *)
          if M.( > ) n total then M.(head + (n - total)) :: rest
          else M.(head - (total - n)) :: rest )

let gen_division = gen_division_generic (module Int)

let gen_division_currency =
  gen_division_generic
    ( module struct
      include Currency.Amount

      let ( + ) a b = Option.value_exn (a + b)

      let ( - ) a b = Option.value_exn (a - b)

      let of_int = of_nanomina_int_exn

      let to_int = to_nanomina_int
    end )

let imperative_fixed_point root ~f =
  let%map f' = fixed_point f in
  f' root

let gen_imperative_rose_tree ?(p = 0.75) (root_gen : 'a t)
    (node_gen : ('a -> 'a) t) =
  let%bind root = root_gen in
  imperative_fixed_point root ~f:(fun self ->
      match%bind size with
      | 0 ->
          return (fun parent -> Rose_tree.T (parent, []))
      | n ->
          let%bind fork_count = geometric ~p 1 >>| Int.max n in
          let%bind fork_sizes = gen_division n fork_count in
          let positive_fork_sizes =
            List.filter fork_sizes ~f:(fun s -> s > 0)
          in
          let%map forks =
            map_gens positive_fork_sizes ~f:(fun s ->
                tuple2 node_gen (with_size ~size:(s - 1) self) )
          in
          fun parent ->
            Rose_tree.T
              (parent, List.map forks ~f:(fun (this, f) -> f (this parent))) )

let gen_imperative_ktree ?(p = 0.75) (root_gen : 'a t) (node_gen : ('a -> 'a) t)
    =
  let%bind root = root_gen in
  imperative_fixed_point root ~f:(fun self ->
      match%bind size with
      | 0 ->
          return (fun _ -> [])
      (* this case is optional but more effecient *)
      | 1 ->
          let%map this = node_gen in
          fun parent -> [ this parent ]
      | n ->
          let%bind this = node_gen in
          let%bind fork_count = geometric ~p 1 >>| Int.max n in
          let%bind fork_sizes = gen_division (n - 1) fork_count in
          let%map forks =
            map_gens fork_sizes ~f:(fun s -> with_size ~size:s self)
          in
          fun parent ->
            let x = this parent in
            x :: List.bind forks ~f:(fun f -> f x) )

let gen_imperative_list (root_gen : 'a t) (node_gen : ('a -> 'a) t) =
  let%bind root = root_gen in
  imperative_fixed_point root ~f:(fun self ->
      match%bind size with
      | 0 ->
          return (fun _ -> [])
      | n ->
          let%bind this = node_gen in
          let%map f = with_size ~size:(n - 1) self in
          fun parent -> parent :: f (this parent) )

let%test_module "Quickcheck lib tests" =
  ( module struct
    let%test_unit "gen_imperative_list" =
      let increment = ( + ) 2 in
      let root = 1 in
      let root_gen = return root in
      let gen =
        Int.gen_incl 2 100
        >>= fun size ->
        Quickcheck.Generator.with_size ~size
          (gen_imperative_list root_gen (return increment))
      in
      Quickcheck.test gen ~f:(fun list ->
          match list with
          | [] ->
              failwith "We assume that our list has at least one element"
          | x :: xs ->
              assert (x = root) ;
              let result =
                List.fold_result xs ~init:x ~f:(fun elem next_elem ->
                    if next_elem = increment elem then Result.return next_elem
                    else
                      Or_error.errorf
                        !"elements do not add up correctly %d %d"
                        elem next_elem )
              in
              assert (Result.is_ok result) )
  end )

1	(* quickcheck_lib.ml *)
2		9✔
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 =
10	match ls with	×
11	\| [] ->	×
12	return []
13	\| h :: t ->	×
14	let%bind h' = f h in	×
15	let%map t' = map_gens t ~f in	×
16	h' :: t'	×
17
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 =
21	let rec go : 'a list -> int -> 'a list Quickcheck.Generator.t =	×
22	fun xs n' ->
23	if n' < n then f n' >>= fun x -> go (x :: xs) (n' + 1)	×
24	else return @@ List.rev xs	×
25	in
26	go [] 0
27
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. *)
37	let rec go n =	×
38	if n < Array.length arr then (	×
39	let%bind swap_idx = Int.gen_uniform_incl n (Array.length arr - 1) in	×
40	Array.swap arr n swap_idx ;	×
41	go (n + 1) )	×
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 =
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 ->
56	let open Quickcheck.Generator.Let_syntax in	×
57	let%map gammas =
58	map_gens	×
59	(List.init n ~f:(Fn.const ()))	×
60	~f:(fun _ ->
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. *)
64	let%map uniform = Float.gen_uniform_excl 0. 1. in	×
65	Float.log uniform )	×
66	in
67	let sum = List.fold gammas ~init:0. ~f:(fun x y -> x +. y) in	×
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 =
88	if k = 0 then Quickcheck.Generator.return []	×
89	else
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	*)
98	let%bind dirichlet = gen_symm_dirichlet k in	×
99	let n_float = Float.of_int @@ M.to_int n in	×
100	let float_to_mt : float -> t =	×
101	fun fl ->
102	match Float.iround_down fl with	×
103	\| Some int ->	×
104	M.of_int int
105	\| None ->	×
106	failwith "gen_division_generic: out of range"
107	in
108	let res = List.map dirichlet ~f:(fun x -> float_to_mt @@ (x *. n_float)) in	×
109	let total = List.fold res ~f:M.( + ) ~init:M.zero in	×
110	return	×
111	( match res with
112	\| [] ->	×
113	failwith
114	"empty result list in gen_symm_dirichlet, this should be \
115	impossible. "
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	*)
120	if M.( > ) n total then M.(head + (n - total)) :: rest	×
121	else M.(head - (total - n)) :: rest )	×
122
123	let gen_division = gen_division_generic (module Int)	9✔
124
125	let gen_division_currency =
126	gen_division_generic	9✔
127	( module struct
128	include Currency.Amount
129
130	let ( + ) a b = Option.value_exn (a + b)	×
131
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
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
146	imperative_fixed_point root ~f:(fun self ->	×
147	match%bind size with
148	\| 0 ->	×
149	return (fun parent -> Rose_tree.T (parent, []))	×
150	\| n ->	×
151	let%bind fork_count = geometric ~p 1 >>\| Int.max n in	×
152	let%bind fork_sizes = gen_division n fork_count in	×
153	let positive_fork_sizes =	×
154	List.filter fork_sizes ~f:(fun s -> s > 0)	×
155	in
156	let%map forks =
157	map_gens positive_fork_sizes ~f:(fun s ->	×
158	tuple2 node_gen (with_size ~size:(s - 1) self) )	×
159	in
160	fun parent ->
161	Rose_tree.T	×
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" =
200	let increment = ( + ) 2 in	×
201	let root = 1 in
202	let root_gen = return root in
203	let gen =	×
204	Int.gen_incl 2 100	×
205	>>= fun size ->
206	Quickcheck.Generator.with_size ~size	×
207	(gen_imperative_list root_gen (return increment))	×
208	in
209	Quickcheck.test gen ~f:(fun list ->	×
210	match list with	×
211	\| [] ->	×
212	failwith "We assume that our list has at least one element"
213	\| x :: xs ->	×
214	assert (x = root) ;	×
215	let result =
216	List.fold_result xs ~init:x ~f:(fun elem next_elem ->
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
223	assert (Result.is_ok result) )	×
224	end )	9✔

MinaProtocol / mina / 2863

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