diff --git a/src/lib_shell/test/generators.ml b/src/lib_shell/test/generators.ml index c336bcd8647bb8a90d6e2bf2f5b7fe9c19179a28..9e981bf888c82afa3ef1ff4af742bb1d18888504 100644 --- a/src/lib_shell/test/generators.ml +++ b/src/lib_shell/test/generators.ml @@ -29,12 +29,12 @@ let add_if_not_present classification oph op t = Prevalidator_classification.( if not (is_in_mempool oph t) then add classification oph op t) -let string_gen = QCheck.Gen.string ?gen:None +let string_gen = QCheck2.Gen.small_string ?gen:None -let block_hash_gen : Block_hash.t QCheck.Gen.t = - let open QCheck.Gen in +let block_hash_gen : Block_hash.t QCheck2.Gen.t = + let open QCheck2.Gen in let+ key = opt (string_size (0 -- 64)) - and+ path = list_size (0 -- 100) string_gen in + and+ path = list_size (0 -- 10) string_gen in Block_hash.hash_string ?key path (** A generator of operations. @@ -44,8 +44,8 @@ let block_hash_gen : Block_hash.t QCheck.Gen.t = - [block_hash_t] is an optional generator for the branch. If omitted {!block_hash_gen} is used. *) let operation_gen ?(string_gen = string_gen) ?block_hash_t () : - Operation.t QCheck.Gen.t = - let open QCheck.Gen in + Operation.t QCheck2.Gen.t = + let open QCheck2.Gen in let prod_block_hash_gen = Option.value ~default:block_hash_gen block_hash_t in let+ branch = prod_block_hash_gen and+ proto = string_gen >|= Bytes.of_string in @@ -53,8 +53,8 @@ let operation_gen ?(string_gen = string_gen) ?block_hash_t () : (** Like {!operation_gen} with a hash. *) let operation_with_hash_gen ?string_gen ?block_hash_t () : - (Operation_hash.t * Operation.t) QCheck.Gen.t = - let open QCheck.Gen in + (Operation_hash.t * Operation.t) QCheck2.Gen.t = + let open QCheck2.Gen in let+ op = operation_gen ?string_gen ?block_hash_t () in let hash = Operation.hash op in (hash, op) @@ -67,8 +67,8 @@ let operation_with_hash_gen ?string_gen ?block_hash_t () : this generator guarantees that all returned operations are distinct (because their hashes differ). *) let op_map_gen ?string_gen ?block_hash_t () : - Operation.t Operation_hash.Map.t QCheck.Gen.t = - let open QCheck.Gen in + Operation.t Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in let+ ops = small_list (operation_gen ?string_gen ?block_hash_t ()) in (* Op_map.of_seq eliminates duplicate keys (if any) *) List.map (fun op -> (Operation.hash op, op)) ops @@ -76,12 +76,12 @@ let op_map_gen ?string_gen ?block_hash_t () : (** A generator like {!op_map_gen} but which guarantees the size of the returned maps: they are exactly of size [n]. We need - a custom function (as opposed to using a QCheck function for lists + a custom function (as opposed to using a QCheck2 function for lists of fixed lengths) because we *need* to return maps, because we need the properties that all operations hashes are different. *) -let op_map_gen_n ?string_gen ?block_hash_t ~(n : int) : - Operation.t Operation_hash.Map.t QCheck.Gen.t = - let open QCheck.Gen in +let op_map_gen_n ?string_gen ?block_hash_t (n : int) : + Operation.t Operation_hash.Map.t QCheck2.Gen.t = + let open QCheck2.Gen in let map_take_n n m = Operation_hash.Map.bindings m |> List.take_n n |> List.to_seq |> Operation_hash.Map.of_seq @@ -99,8 +99,8 @@ let op_map_gen_n ?string_gen ?block_hash_t ~(n : int) : go Operation_hash.Map.empty (** Do we need richer errors? If so, how to generate those? *) -let classification_gen : classification QCheck.Gen.t = - QCheck.Gen.oneofa +let classification_gen : classification QCheck2.Gen.t = + QCheck2.Gen.oneofa [| `Applied; `Prechecked; @@ -110,18 +110,18 @@ let classification_gen : classification QCheck.Gen.t = `Outdated []; |] -let unrefused_classification_gen : classification QCheck.Gen.t = - QCheck.Gen.oneofa +let unrefused_classification_gen : classification QCheck2.Gen.t = + QCheck2.Gen.oneofa [|`Applied; `Prechecked; `Branch_delayed []; `Branch_refused []|] -let parameters_gen : parameters QCheck.Gen.t = - let open QCheck.Gen in - let+ map_size_limit = 1 -- 100 in +let parameters_gen : parameters QCheck2.Gen.t = + let open QCheck2.Gen in + let+ map_size_limit = 1 -- 30 in let on_discarded_operation _ = () in {map_size_limit; on_discarded_operation} -let t_gen ?(can_be_full = true) () : t QCheck.Gen.t = - let open QCheck.Gen in +let t_gen ?(can_be_full = true) () : t QCheck2.Gen.t = + let open QCheck2.Gen in let* parameters = parameters_gen in let+ inputs = let limit = parameters.map_size_limit - if can_be_full then 0 else 1 in @@ -139,9 +139,9 @@ let t_gen ?(can_be_full = true) () : t QCheck.Gen.t = (* With probability 1/2, we take an operation hash already present in the classification. This operation is taken uniformly among the different classes. *) -let with_t_operation_gen : t -> (Operation_hash.t * Operation.t) QCheck.Gen.t = +let with_t_operation_gen : t -> (Operation_hash.t * Operation.t) QCheck2.Gen.t = let module Classification = Prevalidator_classification in - let open QCheck.Gen in + let open QCheck2 in fun t -> let to_ops map = Operation_hash.Map.bindings map @@ -152,9 +152,15 @@ let with_t_operation_gen : t -> (Operation_hash.t * Operation.t) QCheck.Gen.t = (* If list is empty, it cannot be used as a generator *) let freq_of_list = function [] -> 0 | _ -> 1 in (* If map is not empty, take one of its elements *) - let freq_and_gen_of_map map = (freq_of_map map, oneofl (to_ops map)) in + let freq_and_gen_of_map map = + let b = freq_of_map map in + if b = 1 then [(1, Gen.oneofl (to_ops map))] else [] + in (* If list is not empty, take one of its elements *) - let freq_and_gen_of_list list = (freq_of_list list, oneofl list) in + let freq_and_gen_of_list list = + let b = freq_of_list list in + if b = 1 then [(1, Gen.oneofl list)] else [] + in (* We use max to ensure the ponderation is strictly greater than 0. *) let freq_fresh t = max @@ -165,18 +171,16 @@ let with_t_operation_gen : t -> (Operation_hash.t * Operation.t) QCheck.Gen.t = + freq_of_map (Classification.map t.refused) + freq_of_map (Classification.map t.outdated)) in - frequency - [ - freq_and_gen_of_list t.applied_rev; - freq_and_gen_of_list (Operation_hash.Map.bindings t.prechecked); - freq_and_gen_of_map (Classification.map t.branch_refused); - freq_and_gen_of_map (Classification.map t.branch_delayed); - freq_and_gen_of_map (Classification.map t.refused); - freq_and_gen_of_map (Classification.map t.outdated); - (freq_fresh t, operation_with_hash_gen ()); - ] + freq_and_gen_of_list t.applied_rev + @ freq_and_gen_of_list (Operation_hash.Map.bindings t.prechecked) + @ freq_and_gen_of_map (Classification.map t.branch_refused) + @ freq_and_gen_of_map (Classification.map t.branch_delayed) + @ freq_and_gen_of_map (Classification.map t.refused) + @ freq_and_gen_of_map (Classification.map t.outdated) + @ [(freq_fresh t, operation_with_hash_gen ())] + |> Gen.frequency let t_with_operation_gen ?can_be_full () : - (t * (Operation_hash.t * Operation.t)) QCheck.Gen.t = - let open QCheck.Gen in + (t * (Operation_hash.t * Operation.t)) QCheck2.Gen.t = + let open QCheck2.Gen in t_gen ?can_be_full () >>= fun t -> pair (return t) (with_t_operation_gen t) diff --git a/src/lib_shell/test/test_prevalidation_t.ml b/src/lib_shell/test/test_prevalidation_t.ml index 8882f785030b261f1db5652d4733013e8a873dc5..ecf9644d3ef34ca4860ee2e53a4caca7cd49bae0 100644 --- a/src/lib_shell/test/test_prevalidation_t.ml +++ b/src/lib_shell/test/test_prevalidation_t.ml @@ -130,7 +130,7 @@ let test_create ctxt = all different). Returned maps are exactly of size [n]. *) let prevalidation_operations_gen (module P : Prevalidation.T with type operation_data = unit) ~(n : int) : - unit Prevalidation.operation list QCheck.Gen.t = + unit Prevalidation.operation list QCheck2.Gen.t = let mk_operation (_, (raw : Operation.t)) : unit Prevalidation.operation = match P.parse raw with | Ok x -> x @@ -138,13 +138,13 @@ let prevalidation_operations_gen Format.printf "%a" Error_monad.pp_print_trace err ; assert false in - let open QCheck.Gen in + let open QCheck2.Gen in (* We need to specify the protocol bytes generator to always generate the empty string, otherwise the call to [P.parse] will fail with the bytes being too long (hereby looking like an attack). *) - let string_gen : string QCheck.Gen.t = QCheck.Gen.return "" in + let string_gen : string QCheck2.Gen.t = QCheck2.Gen.return "" in let+ (ops : Operation.t Operation_hash.Map.t) = - Generators.op_map_gen_n ~string_gen ?block_hash_t:None ~n + Generators.op_map_gen_n ~string_gen ?block_hash_t:None n in List.map mk_operation (Operation_hash.Map.bindings ops) @@ -154,8 +154,7 @@ let nb_ops = 100 let mk_ops (module P : Prevalidation.T with type operation_data = unit) : unit Prevalidation.operation list = let ops = - QCheck.Gen.generate ~n:1 (prevalidation_operations_gen (module P) ~n:nb_ops) - |> List.concat + QCheck2.Gen.generate1 (prevalidation_operations_gen (module P) ~n:nb_ops) in assert (Compare.List_length_with.(ops = nb_ops)) ; ops @@ -188,11 +187,12 @@ let test_apply_operation_crash ctxt = (** Logical implication *) let ( ==> ) a b = (not a) || b -(** Returns a random generator initialized with a seed from [QCheck] *) +(** Returns a random generator initialized with a seed from [QCheck2] *) let mk_rand () = - (* We use QCheck as the source of randomness, as we hope one day - this will become a traditional QCheck test. *) - QCheck.Gen.generate ~n:8 QCheck.Gen.int |> Array.of_list |> Random.State.make + (* We use QCheck2 as the source of randomness, as we hope one day + this will become a traditional QCheck2 test. *) + QCheck2.Gen.generate ~n:8 QCheck2.Gen.int + |> Array.of_list |> Random.State.make (** [mk_live_operations rand ops] returns a subset of [ops], which is appropriate for being passed as the [live_operations] argument diff --git a/src/lib_shell/test/test_prevalidator_classification.ml b/src/lib_shell/test/test_prevalidator_classification.ml index 248d8c9c804fb74eba6df2c7275d3ffc8c75776a..e502785b9ef19b4c5c14a34f65544e8e2b46052c 100644 --- a/src/lib_shell/test/test_prevalidator_classification.ml +++ b/src/lib_shell/test/test_prevalidator_classification.ml @@ -30,7 +30,7 @@ Subject: Unit tests the Prevalidator classification APIs *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module Classification = Prevalidator_classification module Operation_map = struct @@ -91,7 +91,7 @@ module Extra_generators = struct The classification, hash and operation for [Add_if_not_present] events are generated independently from [t]. *) let event_gen t = - let open QCheck.Gen in + let open QCheck2.Gen in let add_gen = let+ (classification, (oph, op)) = pair @@ -117,7 +117,7 @@ module Extra_generators = struct operation hash in the case of a [Remove] event) is the [t] obtained by having applied all previous events to [t_initial]. *) let t_with_event_sequence_gen = - let open QCheck.Gen in + let open QCheck2.Gen in Generators.t_gen () >>= fun t -> let t_initial = Internal_for_tests.copy t in let rec loop acc_gen n = @@ -156,7 +156,7 @@ let qcheck_bounded_map_is_empty bounded_map = let disjoint_union_classified_fields ?fail_msg (t : Classification.t) = let ( +> ) acc next_set = if not (Operation_hash.Set.disjoint acc next_set) then - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "Invariant 'The fields: [refused; outdated; branch_refused; \ branch_delayed; applied] are disjoint' broken by t =@.%a@.%s" Classification.Internal_for_tests.pp @@ -208,7 +208,7 @@ let check_invariants ?fail_msg (t : Classification.t) = set_pp set2 in - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "Invariant 'The field [in_mempool] is the set of all operation hashes \ present in fields: [refused; outdated; branch_refused; branch_delayed; \ applied]' broken by t =@.%a\n\ @@ -247,12 +247,12 @@ let event_pp pp = function Format.fprintf pp "Flush ~handle_branch_refused:%b" handle_branch_refused let test_flush_empties_all_except_refused_and_outdated = - let open QCheck in + let open QCheck2 in Test.make ~name: "[flush ~handle_branch_refused:true] empties everything except [refused] \ and [outdated]" - (make (Generators.t_gen ())) + (Generators.t_gen ()) @@ fun t -> let refused_before = t.refused |> Classification.map in let outdated_before = t.outdated |> Classification.map in @@ -276,12 +276,12 @@ let test_flush_empties_all_except_refused_and_outdated = () let test_flush_empties_all_except_refused_and_branch_refused = - let open QCheck in + let open QCheck2 in Test.make ~name: "[flush ~handle_branch_refused:false] empties everything except \ [refused], [outdated] and [branch_refused]" - (make (Generators.t_gen ())) + (Generators.t_gen ()) @@ fun t -> let refused_before = t.refused |> Classification.map in let outdated_before = t.outdated |> Classification.map in @@ -314,12 +314,10 @@ let test_flush_empties_all_except_refused_and_branch_refused = () let test_is_in_mempool_remove = - let open QCheck in + let open QCheck2 in Test.make ~name:"[is_in_mempool] and [remove_*] are well-behaved" - (make - @@ Generators.( - Gen.pair (t_with_operation_gen ()) unrefused_classification_gen)) + Generators.(Gen.pair (t_with_operation_gen ()) unrefused_classification_gen) @@ fun ((t, (oph, op)), unrefused_classification) -> Classification.add unrefused_classification oph op t ; qcheck_eq_true ~actual:(Classification.is_in_mempool oph t) ; @@ -328,10 +326,10 @@ let test_is_in_mempool_remove = true let test_is_applied = - let open QCheck in + let open QCheck2 in Test.make ~name:"[is_applied] is well-behaved" - (make @@ Generators.(Gen.pair (t_gen ()) (operation_with_hash_gen ()))) + Generators.(Gen.pair (t_gen ()) (operation_with_hash_gen ())) @@ fun (t, (oph, op)) -> Classification.add `Applied oph op t ; qcheck_eq_true ~actual:(Classification.is_in_mempool oph t) ; @@ -343,11 +341,12 @@ let test_is_applied = true let test_invariants = - QCheck.Test.make + let open QCheck2 in + Test.make ~name: "invariants are preserved through any sequence of events (provided we do \ not [add] already present operations)" - (QCheck.make Extra_generators.t_with_event_sequence_gen) + Extra_generators.t_with_event_sequence_gen @@ fun (t, events) -> let _ = List.fold_left @@ -375,7 +374,7 @@ module Bounded = struct * binding list * binding list - let custom_print : custom QCheck.Print.t = + let custom_print : custom QCheck2.Print.t = fun (t, classification, first_bindings, other_bindings) -> let classification_string = match classification with @@ -401,8 +400,8 @@ module Bounded = struct other_bindings let custom_gen (discarded_operations_rev : Operation_hash.t list ref) : - custom QCheck.Gen.t = - let open QCheck.Gen in + custom QCheck2.Gen.t = + let open QCheck2.Gen in let* map_size_limit = 1 -- 20 in let on_discarded_operation oph = discarded_operations_rev := oph :: !discarded_operations_rev @@ -442,7 +441,7 @@ module Bounded = struct excess_hashes) then let hashes_pp = Format.pp_print_list Operation_hash.pp in - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "Expected all excess hashes to have been discarded but it was \ not.@.Excess hashes:@.%a@.Discarded hashes:@.%a" hashes_pp @@ -456,7 +455,7 @@ module Bounded = struct Operation_hash.Map.bindings (Classification.map bounded_map) <> expected_size) then - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "Expected bounded_map to be full (size = %i) but its actual size is \ %i.@.Bounded_map content:@.%a" expected_size @@ -466,19 +465,21 @@ module Bounded = struct bounded_map let test_bounded = + let open QCheck2 in let discarded_operations_rev = ref [] in - QCheck.Test.make + Test.make ~name: "When more error operations than the size limit are added, then the \ first operations are discarded" - (QCheck.make ~print:custom_print @@ custom_gen discarded_operations_rev) + ~print:custom_print + (custom_gen discarded_operations_rev) @@ fun (t, error_classification, first_bindings, other_bindings) -> (* We must not have duplicate operation hashes otherwise we may not go over the bound *) let hashes = first_bindings @ other_bindings |> List.map (fun (hash, _) -> hash) in let unique_hashes = Operation_hash.Set.of_list hashes in - QCheck.assume + QCheck2.assume Compare.List_length_with.( hashes = Operation_hash.Set.cardinal unique_hashes) ; (* Remove all operations for the tested classification *) @@ -568,9 +569,10 @@ module To_map = struct (** Tests the relationship between [Classification.create] and [Classification.to_map] *) let test_create = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[to_map_all (create params)] is empty" - (QCheck.make Generators.parameters_gen) + Generators.parameters_gen @@ fun parameters -> let t = Classification.create parameters in qcheck_eq' @@ -583,12 +585,12 @@ module To_map = struct (** Tests the relationship between [Classification.add] and [Classification.to_map] *) let test_add = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[add] extends the size of [to_map] by 0 or 1" - (QCheck.make - (QCheck.Gen.pair - (Generators.t_with_operation_gen ()) - Generators.classification_gen)) + (Gen.pair + (Generators.t_with_operation_gen ()) + Generators.classification_gen) @@ fun ((t, (oph, op)), classification) -> let initial = to_map_all t in Classification.add classification oph op t ; @@ -603,9 +605,10 @@ module To_map = struct (** Tests the relationship between [Classification.remove] and [Classification.to_map] *) let test_remove = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[remove] reduces the size of [to_map] by 0 or 1" - (QCheck.make (Generators.t_with_operation_gen ())) + (Generators.t_with_operation_gen ()) @@ fun (t, (oph, _)) -> let initial = to_map_all t in drop oph t ; @@ -635,14 +638,14 @@ module To_map = struct This property is true only if [t] is not full with regard to the classification of the operation. *) - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"Check property between map, remove and add (1)" ~count:1000 - (QCheck.make - ~print:to_string - (QCheck.Gen.pair - (Generators.t_with_operation_gen ~can_be_full:false ()) - Generators.classification_gen)) + ~print:to_string + (Gen.pair + (Generators.t_with_operation_gen ~can_be_full:false ()) + Generators.classification_gen) @@ fun ((t, (oph, op)), classification) -> let t' = Classification.Internal_for_tests.copy t in drop oph t ; @@ -675,13 +678,13 @@ module To_map = struct Operation_hash.pp oph in - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"Check property between map, remove and add (2)" - (QCheck.make - ~print:to_string - (QCheck.Gen.pair - (Generators.t_with_operation_gen ~can_be_full:false ()) - Generators.classification_gen)) + ~print:to_string + (Gen.pair + (Generators.t_with_operation_gen ~can_be_full:false ()) + Generators.classification_gen) @@ fun ((t, (oph, op)), classification) -> let t' = Classification.Internal_for_tests.copy t in Classification.add classification oph op t ; @@ -699,9 +702,10 @@ module To_map = struct (** Tests the relationship between [Classification.flush] and [Classification.to_map] *) let test_flush = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[flush] can be emulated by [to_map ~refused:true ..]" - (QCheck.make (QCheck.Gen.pair (Generators.t_gen ()) QCheck.Gen.bool)) + (Gen.pair (Generators.t_gen ()) Gen.bool) @@ fun (t, handle_branch_refused) -> let initial = Classification.Internal_for_tests.to_map @@ -720,9 +724,10 @@ module To_map = struct (** Tests the relationship between [Classification.is_in_mempool] and [Classification.to_map] *) let test_is_in_mempool = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[is_in_mempool] can be emulated by [to_map]" - (QCheck.make (Generators.t_with_operation_gen ())) + (Generators.t_with_operation_gen ()) @@ fun (t, (oph, _)) -> let is_in_mempool = Classification.is_in_mempool oph t in let map = @@ -736,9 +741,10 @@ module To_map = struct (** Tests that [Classification.to_map] returns an empty map if all parameters are set to [false] *) let test_none = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[to_map] returns an empty map if all parameters are set to [false]" - (QCheck.make (Generators.t_gen ())) + (Generators.t_gen ()) @@ fun t -> qcheck_eq' ~pp:map_pp diff --git a/src/lib_shell/test/test_prevalidator_classification_operations.ml b/src/lib_shell/test/test_prevalidator_classification_operations.ml index 6a73fbee1c6170b0a8f0727e2371214cf537760f..a5598196b884fe4dfd4c0d0e487173d8793867cd 100644 --- a/src/lib_shell/test/test_prevalidator_classification_operations.ml +++ b/src/lib_shell/test/test_prevalidator_classification_operations.ml @@ -31,7 +31,7 @@ and [Prevalidator_classification.recyle_operations] *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers module Op_map = Operation_hash.Map module Classification = Prevalidator_classification @@ -290,10 +290,10 @@ end module External_generators = Generators -(** [QCheck] generators used in tests below *) +(** [QCheck2] generators used in tests below *) module Generators = struct - let block_gen : Block.t QCheck.Gen.t = - let open QCheck.Gen in + let block_gen : Block.t QCheck2.Gen.t = + let open QCheck2.Gen in let* ops = let ops_list_gen = (* Having super long list of operations isn't necessary. @@ -310,18 +310,15 @@ module Generators = struct (* A generator of lists of {!Block.t} where all elements are guaranteed to be different. *) - let unique_block_gen : Block.Set.t QCheck.Gen.t = - QCheck.Gen.(small_list block_gen >|= Block.Set.of_list) + let unique_block_gen : Block.Set.t QCheck2.Gen.t = + QCheck2.Gen.(small_list block_gen >|= Block.Set.of_list) (* A generator of lists of {!Block.t} where all elements are guaranteed to be different and returned lists are guaranteed to be non empty. *) let unique_nonempty_block_gen = - let open QCheck.Gen in - let opt_gen = - let+ l = unique_block_gen in - if Block.Set.is_empty l then None else Some l - in - of_option_gen opt_gen + let open QCheck2.Gen in + let+ block = block_gen and+ l = unique_block_gen in + Block.Set.add block l (** A tree generator. Written in a slightly unusual style because it generates all values beforehand, to make sure they are all different. @@ -337,8 +334,8 @@ module Generators = struct This generator takes as parameter an optional list of blocks. If they are given, they are used to build the tree; otherwise fresh ones are generated. *) - let tree_gen ?blocks = - let open QCheck.Gen in + let tree_gen ?blocks () = + let open QCheck2.Gen in let* (blocks : Block.t list) = match blocks with | None -> @@ -346,7 +343,7 @@ module Generators = struct of the generator, to guarantee [blocks <> []] below. *) unique_nonempty_block_gen >|= Block.set_to_list | Some [] -> - QCheck.Test.fail_report + QCheck2.Test.fail_report "tree_gen should not be called with an empty list of blocks" | Some blocks -> (* take blocks passed as parameters *) @@ -358,7 +355,7 @@ module Generators = struct | [] -> return None | [x] -> ret (Tree.Leaf x) | x :: xs -> ( - let* one_child = QCheck.Gen.bool in + let* one_child = QCheck2.Gen.bool in if one_child then let* sub = go xs in match sub with @@ -366,7 +363,7 @@ module Generators = struct | Some sub -> ret (Tree.Node1 (x, sub)) else let* (left, right) = - QCheck.Gen.int_bound (List.length xs - 1) + QCheck2.Gen.int_bound (List.length xs - 1) >|= List_extra.split_n xs in let* left = go left and* right = go right in @@ -382,7 +379,7 @@ module Generators = struct (** A generator for passing the last argument of [Prevalidator.handle_live_operations] *) let old_mempool_gen (tree : Block.t Tree.tree) : - Operation.t Operation_hash.Map.t QCheck.Gen.t = + Operation.t Operation_hash.Map.t QCheck2.Gen.t = let blocks = Tree.values tree in let pairs = List.map Block.tools.operations blocks |> List.concat |> List.concat @@ -390,10 +387,10 @@ module Generators = struct let elements = List.map (fun (op : Operation.t) -> (Operation.hash op, op)) pairs in - if elements = [] then QCheck.Gen.return Operation_hash.Map.empty + if elements = [] then QCheck2.Gen.return Operation_hash.Map.empty else - let list_gen = QCheck.Gen.(oneofl elements |> list) in - QCheck.Gen.map + let list_gen = QCheck2.Gen.(oneofl elements |> list) in + QCheck2.Gen.map (fun l -> Operation_hash.Map.of_seq (List.to_seq l)) list_gen @@ -407,14 +404,14 @@ module Generators = struct If given, the specified [?blocks] are used. Otherwise they are generated. *) - let chain_tools_gen ?blocks : + let chain_tools_gen ?blocks () : (Block.t Classification.chain_tools * Block.t Tree.tree * (Block.t * Block.t) option * Operation.t Operation_hash.Map.t) - QCheck.Gen.t = - let open QCheck.Gen in - let* tree = tree_gen ?blocks in + QCheck2.Gen.t = + let open QCheck2.Gen in + let* tree = tree_gen ?blocks () in assert (Tree.well_formed Block.compare tree) ; let predecessor_pairs = Tree.predecessor_pairs tree in let equal = Block.equal in @@ -485,21 +482,17 @@ module Generators = struct return (res, tree, chosen_pair, old_mempool) (** [split_in_two l] is a generator producing [(l1, l2)] such that [l1 @ l2 = l] *) - let split_in_two (l : 'a list) : ('a list * 'a list) QCheck.Gen.t = - let open QCheck.Gen in + let split_in_two (l : 'a list) : ('a list * 'a list) QCheck2.Gen.t = + let open QCheck2.Gen in let length = List.length l in let+ i = 0 -- length in List_extra.split_n l i end -module Arbitraries = struct - let chain_tools_arb = QCheck.make Generators.chain_tools_gen -end - (** Function to unwrap an [option] when it MUST be a [Some] *) let force_opt ~loc = function | Some x -> x - | None -> QCheck.Test.fail_reportf "Unexpected None at %s" loc + | None -> QCheck2.Test.fail_reportf "Unexpected None at %s" loc (* Values from [start] (included) to [ancestor] (excluded) *) let values_from_to ~(equal : 'a -> 'a -> bool) (tree : 'a Tree.tree) @@ -534,11 +527,11 @@ let qcheck_cond ?pp ~cond e1 e2 () = else match pp with | None -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[The condition check failed, but no pretty printer was \ provided.@]" | Some pp -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[The condition check failed!@,\ first element:@,\ %a@,\ @@ -575,9 +568,9 @@ module Handle_operations = struct Could be in [chain_tools_gen] itself, but only used in this test. So it would be overkill. *) let gen = - let open QCheck.Gen in + let open QCheck2.Gen in let* (chain, tree, pair_blocks_opt, old_mempool) = - Generators.chain_tools_gen ?blocks:None + Generators.chain_tools_gen ?blocks:None () in let* live_blocks = sublist (Tree.values tree) @@ -590,12 +583,11 @@ module Handle_operations = struct old_mempool, Block_hash.Set.of_list live_blocks ) in - let arb = QCheck.make gen in - QCheck.Test.make + QCheck2.Test.make ~name:"[handle_live_operations] is a subset of alive blocks" - arb + gen @@ fun (chain, tree, pair_blocks_opt, old_mempool, live_blocks) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let expected_superset : Operation.t Op_map.t = (* Take all blocks *) @@ -625,11 +617,11 @@ module Handle_operations = struct operations on the "path" between [from_branch] and [to_branch] (when all blocks are considered live). *) let test_handle_live_operations_path_spec = - QCheck.Test.make + QCheck2.Test.make ~name:"[handle_live_operations] path specification" - Arbitraries.chain_tools_arb + (Generators.chain_tools_gen ()) @@ fun (chain, tree, pair_blocks_opt, _) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let equal = Block.equal in let ancestor : Block.t = @@ -668,11 +660,11 @@ module Handle_operations = struct are operations on the path from [ancestor] to [to_branch] (when all operations are deemed up-to-date). *) let test_handle_live_operations_clear = - QCheck.Test.make + QCheck2.Test.make ~name:"[handle_live_operations] clear approximation" - Arbitraries.chain_tools_arb + Generators.(chain_tools_gen ()) @@ fun (chain, tree, pair_blocks_opt, old_mempool) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let cleared = ref Operation_hash.Set.empty in let clearer oph = cleared := Operation_hash.Set.add oph !cleared in @@ -706,11 +698,11 @@ module Handle_operations = struct (** Test that operations injected by [handle_live_operations] are operations on the path from [ancestor] to [from_branch]. *) let test_handle_live_operations_inject = - QCheck.Test.make + QCheck2.Test.make ~name:"[handle_live_operations] inject approximation" - Arbitraries.chain_tools_arb + (Generators.chain_tools_gen ()) @@ fun (chain, tree, pair_blocks_opt, old_mempool) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let injected = ref Operation_hash.Set.empty in let inject_operation oph _op = @@ -756,8 +748,8 @@ module Recyle_operations = struct classes of {!Prevalidator_classification.t}. This generator is NOT a fully random generator like {!Prevalidator_generators.t_gen}. *) let classification_of_ops_gen (ops : Operation.t Op_map.t) : - Classification.t QCheck.Gen.t = - let open QCheck.Gen in + Classification.t QCheck2.Gen.t = + let open QCheck2.Gen in let bindings = Operation_hash.Map.bindings ops in let length = List.length bindings in let* empty_space = 0 -- 100 in @@ -794,7 +786,7 @@ module Recyle_operations = struct that this is not a precondition of [recycle_operations], it's to test the typical use case. *) let gen = - let open QCheck.Gen in + let open QCheck2.Gen in let* blocks = Generators.unique_nonempty_block_gen >|= Block.set_to_list in assert (blocks <> []) ; let to_ops (blk : Block.t) = List.concat blk.operations in @@ -821,12 +813,12 @@ module Recyle_operations = struct Op_map.bindings classification_pendings_ops |> Generators.split_in_two >|= both oph_op_list_to_map in - let* (chain_tools, tree, from_to, _) = Generators.chain_tools_gen ~blocks in + let* (chain_tools, tree, from_to, _) = + Generators.chain_tools_gen ~blocks () + in let+ classification = classification_of_ops_gen classification_ops in (chain_tools, tree, from_to, classification, pending_ops) - let arb = QCheck.make gen - (** Test that {!Classification.recycle_operations} returns an empty map when live blocks are empty. @@ -840,12 +832,13 @@ module Recyle_operations = struct is partly random for them). This makes lifting the [handle_operations] test quite heavy. We don't do that. *) let test_recycle_operations_empty_live_blocks = - QCheck.Test.make + let open QCheck2 in + Test.make ~name:"[recycle_operations ~live_blocks:empty] is empty" - (QCheck.pair arb QCheck.bool) + Gen.(pair gen bool) @@ fun ( (chain, _tree, pair_blocks_opt, classification, pending), handle_branch_refused ) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let actual : Operation.t Op_map.t = Classification.recycle_operations @@ -867,12 +860,12 @@ module Recyle_operations = struct - classified in the classification data structure - sent as [pending]. *) let test_recycle_operations_returned_value_spec = - QCheck.Test.make + QCheck2.Test.make ~name:"[recycle_operations] returned value can be approximated" - (QCheck.pair arb QCheck.bool) + QCheck2.Gen.(pair gen bool) @@ fun ( (chain, tree, pair_blocks_opt, classification, pending), handle_branch_refused ) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let (from_branch, to_branch) = force_opt ~loc:__LOC__ pair_blocks_opt in let equal = Block.equal in let ancestor : Block.t = @@ -935,12 +928,12 @@ module Recyle_operations = struct (** Test that the classification is appropriately trimmed by {!Classification.recycle_operations} *) let test_recycle_operations_classification = - QCheck.Test.make + QCheck2.Test.make ~name:"[recycle_operations] correctly trims its input classification" - (QCheck.pair arb QCheck.bool) + QCheck2.Gen.(pair gen bool) @@ fun ( (chain, tree, pair_blocks_opt, classification, pending), handle_branch_refused ) -> - QCheck.assume @@ Option.is_some pair_blocks_opt ; + QCheck2.assume @@ Option.is_some pair_blocks_opt ; let live_blocks : Block_hash.Set.t = Tree.values tree |> List.map Block.to_hash |> Block_hash.Set.of_list in diff --git a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml index f3c35e7c89191a28975a542740ff6b2b52ce507c..762795e81b8be06a103484f15e69271e674956f8 100644 --- a/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml +++ b/src/lib_shell/test/test_synchronisation_heuristic_fuzzy.ml @@ -31,7 +31,7 @@ Subject: Test the synchronisation heuristic with a reference implementation *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (* Interface implemented by the synchronisation heuristic. *) @@ -52,7 +52,7 @@ end (* This is a reference implementation for the synchronisation heuristic. It should behave exactly as the one provided in the [Synchronisation_heuristic] module but it is less efficient. With - QCheck, we check that both implementations have the same + QCheck2, we check that both implementations have the same behavior. *) module Reference : S = struct type status = Chain_validator_worker_state.Event.synchronisation_status = @@ -127,64 +127,45 @@ let forge_peer_id () = identity.peer_id let peer_id = - let open QCheck in - let p1 = forge_peer_id () in - let p2 = forge_peer_id () in - let p3 = forge_peer_id () in - let p4 = forge_peer_id () in - let p5 = forge_peer_id () in - let p6 = forge_peer_id () in - let p7 = forge_peer_id () in - let p8 = forge_peer_id () in - let p9 = forge_peer_id () in - let pp_peer_id pid = - let id = - if pid == p1 then "P1" - else if pid == p2 then "P2" - else if pid == p3 then "P3" - else if pid == p4 then "P4" - else if pid == p5 then "P5" - else if pid == p6 then "P6" - else if pid == p7 then "P7" - else if pid == p8 then "P8" - else if pid == p9 then "P9" - else "fresh" - in - Format.asprintf "peer: %s" id + let open QCheck2.Gen in + (* These are generated upfront *) + let static = + ["P1"; "P2"; "P3"; "P4"; "P5"; "P6"; "P7"; "P8"; "P9"] + |> List.map (fun name -> pure (forge_peer_id (), name)) in - (map (fun () -> forge_peer_id ()) unit |> set_print pp_peer_id) - :: - List.map - (fun p -> make ~print:pp_peer_id (Gen.return p)) - [p1; p2; p3; p4; p5; p6; p7; p8; p9] - |> choose + (* The returned generator either produces one of [P1] to [P9] or a fresh one *) + delay (fun () -> oneof (pure (forge_peer_id (), "fresh") :: static)) let now = Time.System.to_protocol @@ Systime_os.now () let forge_timestamp ~delay = Time.Protocol.add now (Int64.of_int delay) +let timestamp_pp n = + let delay = Time.Protocol.diff n now in + Format.asprintf "delay: %Ld" delay + let timestamp = - let open QCheck in - let timestamp_pp n = - let delay = Time.Protocol.diff n now in - Format.asprintf "delay: %Ld" delay - in - map + let open QCheck2 in + Gen.map (fun pre_delay -> let delay = (pre_delay * 20) - 300 in (* ~ [ -300; 100] with a step of 20 *) forge_timestamp ~delay) - (make (Gen.oneof [Gen.return 5; Gen.int_range 0 20])) - |> set_print timestamp_pp + Gen.(oneof [pure 5; 0 -- 20]) let value = - let open QCheck in + let open QCheck2.Gen in pair timestamp peer_id +let print_value (time_stamp, (_, peer_id_str)) = + Printf.sprintf "(%s, %s)" (timestamp_pp time_stamp) peer_id_str + let values = - let open QCheck in + let open QCheck2.Gen in list value +let print_values = QCheck2.Print.list print_value + let pp fmt = let open Reference in function @@ -195,15 +176,17 @@ let pp fmt = Format.fprintf fmt "Synchronised (not stuck)" let make_tests check_update lcreate rcreate threshold latency = + let open QCheck2 in let threshold_1 = - QCheck.Test.make + Test.make ~name: (Format.asprintf "Shell.synchronisation_heuristic.equivalence-with-reference-implementation \ (threshold %d) (latency %d)" 1 latency) - QCheck.(pair value value) + ~print:Print.(pair print_value print_value) + Gen.(pair value value) (fun (v1, v2) -> let state_left = lcreate ~threshold:1 ~latency in let state_right = rcreate ~threshold:1 ~latency in @@ -213,13 +196,14 @@ let make_tests check_update lcreate rcreate threshold latency = let threshold_n = List.map (fun threshold -> - QCheck.Test.make + Test.make ~name: (Format.asprintf "Shell.synchronisation_heuristic.equivalence-with-reference-implementation \ (threshold %d) (latency %d)" threshold latency) + ~print:print_values values (fun values -> let state_left = lcreate ~threshold ~latency in @@ -234,11 +218,12 @@ let make_tests check_update lcreate rcreate threshold latency = let tests = (* The module Synchronisation_heuristic should have the same semantics as the reference implementation given in the Reference - module. We use QCheck to generate a bunch of updates and check + module. We use QCheck2 to generate a bunch of updates and check that both implementations send the same result. *) let module L = Synchronisation_heuristic.Core in let module R = Reference in - let check_update state_left state_right value = + let check_update state_left state_right (time_stamp, (peer_id, _)) = + let value = (time_stamp, peer_id) in L.update state_left value ; R.update state_right value ; qcheck_eq'