From 5790d2c38672970c2258b260011091aeb351011c Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 16 May 2022 17:23:28 +0200 Subject: [PATCH 1/7] Proto_alpha/lib_plugin: migrate to QCheck2 --- .../lib_plugin/test/test_consensus_filter.ml | 2 +- src/proto_alpha/lib_plugin/test/test_filter_state.ml | 12 ++++++------ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml b/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml index 3011feeb6470..746ca41ac6fc 100644 --- a/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml +++ b/src/proto_alpha/lib_plugin/test/test_consensus_filter.ml @@ -395,7 +395,7 @@ let test_not_acceptable_next_level = ( ((proposal_round, op_round), (proposal_level, _)), (proposal_timestamp, now_timestamp) ) ) -> let op_level = Raw_level.succ proposal_level in - QCheck.assume + QCheck2.assume @@ no_error ( timestamp_of_round round_durations diff --git a/src/proto_alpha/lib_plugin/test/test_filter_state.ml b/src/proto_alpha/lib_plugin/test/test_filter_state.ml index 1a06a6762e87..24c8b7a86720 100644 --- a/src/proto_alpha/lib_plugin/test/test_filter_state.ml +++ b/src/proto_alpha/lib_plugin/test/test_filter_state.ml @@ -67,7 +67,7 @@ let test_check_manager_restriction_fresh = with | `Fresh -> true | `Replace _ | `Fail (`Branch_delayed _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a should not be in the set of precheck managers:@,\ %a@]" @@ -110,7 +110,7 @@ let test_check_manager_restriction_fail = with | `Fail (`Branch_delayed _) -> true | `Fresh -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a should be in the set of precheck managers:@,\ %a@]" @@ -119,7 +119,7 @@ let test_check_manager_restriction_fail = pp_state filter_state | `Replace old_oph -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a is in the set of precheck managers:@,\ %a@,\ @@ -164,7 +164,7 @@ let test_check_manager_restriction_replace = with | `Replace _ -> true | `Fresh -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a should be in the set of precheck managers:@,\ %a@]" @@ -173,7 +173,7 @@ let test_check_manager_restriction_replace = pp_state filter_state | `Fail (`Branch_delayed _) -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a is in the set of prechecked managers:@,\ %a but the old version should have been replaced because the new \ @@ -294,7 +294,7 @@ let test_add_manager_restriction_check = ~gas_limit:Alpha_context.Gas.Arith.zero with | `Fresh -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Check manager restriction failed!@,\ %a should be in the set of precheck managers:@,\ %a@]" -- GitLab From 4c5188f044dc9707e9796610c4b4f8d18ef83b6c Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 16 May 2022 18:10:42 +0200 Subject: [PATCH 2/7] Proto_alpha/lib_protocol/test/unit: migrate to QCheck2 --- src/lib_base/test_helpers/tztest.ml | 10 +++ .../test/helpers/test_global_constants.ml | 31 ++++----- .../unit/test_global_constants_storage.ml | 64 +++++++++---------- .../lib_protocol/test/unit/test_round_repr.ml | 14 ++-- .../test/unit/test_sc_rollup_inbox.ml | 46 ++++++------- .../test/unit/test_skip_list_repr.ml | 26 ++++---- 6 files changed, 93 insertions(+), 98 deletions(-) diff --git a/src/lib_base/test_helpers/tztest.ml b/src/lib_base/test_helpers/tztest.ml index 6ae8f99f7ccf..7050f8c88a39 100644 --- a/src/lib_base/test_helpers/tztest.ml +++ b/src/lib_base/test_helpers/tztest.ml @@ -55,6 +55,16 @@ let tztest_qcheck ?count ~name generator f = in Alcotest_lwt.test_case name speed (fun _sw () -> Lwt.return @@ run ()) +let tztest_qcheck2 ?count ~name generator f = + let name, speed, run = + QCheck_alcotest.to_alcotest + ( QCheck2.Test.make ?count ~name generator @@ fun x -> + match Lwt_main.run (f x) with + | Ok _ -> true + | Error err -> QCheck2.Test.fail_reportf "@\n%a@." pp_print_trace err ) + in + Alcotest_lwt.test_case name speed (fun _sw () -> Lwt.return @@ run ()) + let mock_sink : Mock_sink.t Internal_event.sink_definition = (module Mock_sink : Internal_event.SINK with type t = Mock_sink.t) diff --git a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml index cb704d6e0e0f..0ed65437d821 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml @@ -66,8 +66,7 @@ let assume_expr_not_too_large expr = @@ Global_constants_storage.Internal_for_tests.node_too_large node module Generators = struct - let context_arbitrary () = - QCheck.make @@ QCheck.Gen.return (create_context () |> assert_ok_lwt) + let context_gen () = QCheck2.Gen.return (create_context () |> assert_ok_lwt) let prims = [ @@ -215,17 +214,17 @@ module Generators = struct H_constant; ] - let prim_gen = QCheck.Gen.oneofl prims + let prim_gen = QCheck2.Gen.oneofl prims let prims_without_constants_gen = - QCheck.Gen.oneofl (List.filter (fun x -> x != H_constant) prims) + QCheck2.Gen.oneofl (List.filter (fun x -> x != H_constant) prims) - let z_gen = QCheck.Gen.map Z.of_int QCheck.Gen.int + let z_gen = QCheck2.Gen.map Z.of_int QCheck2.Gen.int let micheline_node_gen l_gen p_gen annot_gen : - ('l, 'p) Micheline.node QCheck.Gen.t = + ('l, 'p) Micheline.node QCheck2.Gen.t = let open Micheline in - let open QCheck.Gen in + let open QCheck2.Gen in fix (fun self () -> frequency @@ -297,23 +296,20 @@ module Generators = struct (Seq (l, result), x) let micheline_gen p_gen annot_gen = - QCheck.Gen.map + QCheck2.Gen.map Micheline.strip_locations - (micheline_node_gen (QCheck.Gen.return (-1)) p_gen annot_gen) + (micheline_node_gen (QCheck2.Gen.return (-1)) p_gen annot_gen) let canonical_without_constant_gen () = - QCheck.Gen.map + QCheck2.Gen.map strip_locations (micheline_node_gen - (QCheck.Gen.return (-1)) + (QCheck2.Gen.return (-1)) prims_without_constants_gen - (QCheck.Gen.return [])) - - let canonical_without_constant_arbitrary () = - QCheck.make (canonical_without_constant_gen ()) + (QCheck2.Gen.return [])) let canonical_with_constant_gen () = - let open QCheck.Gen in + let open QCheck2.Gen in canonical_without_constant_gen () >>= fun expr -> let size = Script_repr.micheline_nodes (root expr) in 0 -- (size - 1) >|= fun loc -> @@ -321,7 +317,4 @@ module Generators = struct | _, None -> assert false | node, Some replaced_node -> (expr, strip_locations node, strip_locations replaced_node) - - let canonical_with_constant_arbitrary () = - QCheck.make (canonical_with_constant_gen ()) end diff --git a/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml index 454127b5e679..8f81545ea86d 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_global_constants_storage.ml @@ -36,8 +36,8 @@ open Protocol open Alpha_context open Tztest open Micheline -open QCheck -open Lib_test.Qcheck_helpers +open QCheck2 +open Lib_test.Qcheck2_helpers open Michelson_v1_primitives open Michelson_v1_printer open Test_global_constants @@ -45,11 +45,11 @@ open Test_global_constants (** [get] on a nonexistent global constant returns an error. *) let test_get_on_nonexistent_fails = - tztest_qcheck + tztest_qcheck2 ~name:"get on a nonexistent global constants fails" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_without_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_without_constant_gen ())) (fun (context, expr) -> expr_to_hash expr |> Environment.wrap_tzresult >>?= fun hash -> Global_constants_storage.get context hash @@ -59,11 +59,11 @@ let test_get_on_nonexistent_fails = (** If registering an expression yields a hash [h] and context [c], then [get c h] should yield the original expression. *) let test_get_always_returns_registered_expr = - tztest_qcheck + tztest_qcheck2 ~name:"get always returned the registered constant" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_without_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_without_constant_gen ())) (fun (context, expr) -> Global_constants_storage.register context expr >|= Environment.wrap_tzresult @@ -89,11 +89,11 @@ let test_register_fails_with_unregistered_references = (** Same test as [test_register_fails_with_unregistered_references] but with random values. *) let test_register_fails_with_unregistered_references_pbt = - tztest_qcheck + tztest_qcheck2 ~name:"register: fails with unregistered references pbt" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_with_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_with_constant_gen ())) (fun (context, (_, expr, _)) -> assume_expr_not_too_large expr ; Global_constants_storage.register context expr @@ -122,12 +122,12 @@ let test_register_fails_if_too_deep = (** [expand] on an expression containing a nonexistent global constant returns an error. *) let test_expand_nonexistent_fails = - tztest_qcheck + tztest_qcheck2 ~name: "expand on an expression containing a nonexistent global constant fails" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_with_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_with_constant_gen ())) @@ fun (context, (_, expr, _)) -> assume_expr_not_too_large expr ; Global_constants_storage.expand context expr @@ -146,12 +146,12 @@ let test_expand_no_constants = (** Similar to [test_expand_no_constants], but random. *) let test_register_and_expand_orthogonal = - tztest_qcheck + tztest_qcheck2 ~name:"register and expand are orthogonal" - (triple - (Generators.context_arbitrary ()) - (Generators.canonical_without_constant_arbitrary ()) - (Generators.canonical_without_constant_arbitrary ())) + (Gen.triple + (Generators.context_gen ()) + (Generators.canonical_without_constant_gen ()) + (Generators.canonical_without_constant_gen ())) (fun (context, expr1, expr2) -> assume_expr_not_too_large expr1 ; assume_expr_not_too_large expr2 ; @@ -169,7 +169,7 @@ let test_register_and_expand_orthogonal = let test_expand_deep_constants = tztest "expand: deep constants" `Quick (fun () -> (* Should hold for any n, but this test is very slow, - hence we don't do QCheck. *) + hence we don't do QCheck2. *) let n = 1000 in let expr1 = Expr.from_string "{}" in create_context () >>=? fun context -> @@ -344,11 +344,11 @@ let test_expand_instr_example = original expression [e]*) let test_expand_pbt = let open Michelson_v1_printer in - tztest_qcheck + tztest_qcheck2 ~name:"expand: random" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_with_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_with_constant_gen ())) (fun (context, (full_expr, expr_with_constant, sub_expr)) -> assume_expr_not_too_large full_expr ; assume_expr_not_too_large expr_with_constant ; @@ -362,11 +362,11 @@ let test_expand_pbt = qcheck_eq ~pp:print_expr full_expr result_expr) let test_expand_is_idempotent = - tztest_qcheck + tztest_qcheck2 ~name:"expand is idempotent" - (pair - (Generators.context_arbitrary ()) - (Generators.canonical_with_constant_arbitrary ())) + (Gen.pair + (Generators.context_gen ()) + (Generators.canonical_with_constant_gen ())) (fun (context, (full_expr, expr_with_constant, sub_expr)) -> assume_expr_not_too_large full_expr ; Global_constants_storage.register context sub_expr diff --git a/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml b/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml index 0774c3aabd2e..075396a79ae1 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_round_repr.ml @@ -573,15 +573,15 @@ let round_and_offset_oracle (round_durations : Round_repr.Durations.t) (* Test whether the new version is equivalent to the old one *) let test_round_and_offset_correction = - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"round_and_offset is correct" - QCheck.( - pair - Lib_test.Qcheck_helpers.(pair uint16 uint16) - (Lib_test.Qcheck_helpers.int64_range 0L 100000L)) + QCheck2.( + Gen.pair + Lib_test.Qcheck2_helpers.(Gen.pair uint16 uint16) + (Lib_test.Qcheck2_helpers.int64_range_gen 0L 100000L)) (fun ((first_round_duration, delay_increment_per_round), level_offset) -> - QCheck.assume (first_round_duration > 0) ; - QCheck.assume (delay_increment_per_round > 0) ; + QCheck2.assume (first_round_duration > 0) ; + QCheck2.assume (delay_increment_per_round > 0) ; let first_round_duration = Period_repr.of_seconds_exn (Int64.of_int first_round_duration) and delay_increment_per_round = diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml index d2f4cd14550d..f00a9b1a1856 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_inbox.ml @@ -198,48 +198,44 @@ let test_inclusion_proof_verification (list_of_payloads, n) = let tests = [ Tztest.tztest "Empty inbox" `Quick test_empty; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Added messages are available." - QCheck.(list string) + QCheck2.Gen.(list string) test_add_messages; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Get message." - QCheck.(list string) + QCheck2.Gen.(list string) test_get_message; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Get message payload." - QCheck.(list string) + QCheck2.Gen.(list string) test_get_message_payload; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Consume only available messages." - QCheck.( - make - Gen.( - let* l = list_size small_int string in - let* n = 0 -- ((List.length l * 2) + 1) in - return (l, n))) + QCheck2.Gen.( + let* l = list_size small_int string in + let* n = 0 -- ((List.length l * 2) + 1) in + return (l, n)) test_consume_messages; ] @ let gen_inclusion_proof_inputs = - QCheck.( - make - Gen.( - let small = 2 -- 10 in - let* a = list_size small string in - let* b = list_size small string in - let* l = list_size small (list_size small string) in - let l = a :: b :: l in - let* n = 0 -- (List.length l - 2) in - return (l, n))) + QCheck2.Gen.( + let small = 2 -- 10 in + let* a = list_size small string in + let* b = list_size small string in + let* l = list_size small (list_size small string) in + let l = a :: b :: l in + let* n = 0 -- (List.length l - 2) in + return (l, n)) in [ - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~count:10 ~name:"Produce inclusion proof between two related inboxes." gen_inclusion_proof_inputs test_inclusion_proof_production; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~count:10 ~name:"Verify inclusion proofs." gen_inclusion_proof_inputs diff --git a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml index 3e6cc803b0e0..d10d1345d799 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_skip_list_repr.ml @@ -164,25 +164,21 @@ let test_skip_list_nat_check_invalid_path (basis, i) = let tests = [ - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Skip list: check produced paths for multiple basis." ~count:10 - QCheck.( - make - Gen.( - let* basis = 2 -- 73 in - let* i = 0 -- 100 in - let* j = 0 -- i in - return (basis, i, j))) + QCheck2.Gen.( + let* basis = 2 -- 73 in + let* i = 0 -- 100 in + let* j = 0 -- i in + return (basis, i, j)) test_skip_list_nat_check_path; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"Skip list: reject invalid paths for multiple basis." ~count:10 - QCheck.( - make - Gen.( - let* basis = 2 -- 73 in - let* i = 0 -- 100 in - return (basis, i))) + QCheck2.Gen.( + let* basis = 2 -- 73 in + let* i = 0 -- 100 in + return (basis, i)) test_skip_list_nat_check_invalid_path; ] -- GitLab From a2c8423b819a404a62198ebbb8ce86616dc7a240 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Wed, 18 May 2022 10:39:25 +0200 Subject: [PATCH 3/7] Proto_alpha/lib_protocol/test/migration: migrate to QCheck2 --- .../test/integration/michelson/test_interpretation.ml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml index 7ff42e4752ff..14f45bfd568a 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_interpretation.ml @@ -273,7 +273,7 @@ module Test_map_instr_on_options = struct | Prim (_, D_Pair, [Prim (_, D_Some, [Int (_, prev)], _); Int (_, total)], _) -> {prev = Some (Z.to_int prev); total = Z.to_int total} - | _ -> QCheck.assume_fail () + | _ -> QCheck2.assume_fail () let assertions storage_before storage_after = function | None -> @@ -308,13 +308,10 @@ let tests = `Quick test_multiplication_close_to_overflow_passes; Tztest.tztest "test stack overflow error" `Slow test_stack_overflow; - Tztest.tztest_qcheck + Tztest.tztest_qcheck2 ~name:"test map instr against options" - QCheck.( - triple - (option small_signed_int) - (option small_signed_int) - small_signed_int) + QCheck2.Gen.( + triple (opt small_signed_int) (opt small_signed_int) small_signed_int) Test_map_instr_on_options.test_mapping; ] @ error_encoding_tests -- GitLab From 6198d10b63481b740d5ee90b517d8029c9ac9a52 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 19 May 2022 12:20:07 +0200 Subject: [PATCH 4/7] Proto_alpha/lib_protocol/test/pbt: migrate to QCheck2 --- src/lib_test/qcheck2_helpers.ml | 4 + src/lib_test/qcheck2_helpers.mli | 7 ++ .../helpers/liquidity_baking_generator.ml | 109 +++++++----------- .../helpers/liquidity_baking_generator.mli | 31 +++-- .../test/helpers/test_global_constants.ml | 2 +- .../test/pbt/liquidity_baking_pbt.ml | 36 +++--- .../test/pbt/saturation_fuzzing.ml | 50 ++++---- .../test/pbt/test_carbonated_map.ml | 2 +- .../test/pbt/test_gas_properties.ml | 26 ++--- .../test/pbt/test_refutation_game.ml | 3 +- .../lib_protocol/test/pbt/test_sampler.ml | 16 ++- .../test/pbt/test_sc_rollup_tick_repr.ml | 2 +- .../test/pbt/test_script_comparison.ml | 54 ++++----- .../lib_protocol/test/pbt/test_tez_repr.ml | 65 +++++------ 14 files changed, 198 insertions(+), 209 deletions(-) diff --git a/src/lib_test/qcheck2_helpers.ml b/src/lib_test/qcheck2_helpers.ml index 6e69ad8159b3..2eb6389d34f9 100644 --- a/src/lib_test/qcheck2_helpers.ml +++ b/src/lib_test/qcheck2_helpers.ml @@ -181,6 +181,10 @@ let holey (l : 'a list) : 'a list QCheck2.Gen.t = in List.rev rev_result +let rec of_option_gen gen = + let open QCheck2.Gen in + gen >>= function None -> of_option_gen gen | Some a -> return a + let endpoint_gen = let open QCheck2 in let open Gen in diff --git a/src/lib_test/qcheck2_helpers.mli b/src/lib_test/qcheck2_helpers.mli index 6675a43d40f3..f00d0410c0d5 100644 --- a/src/lib_test/qcheck2_helpers.mli +++ b/src/lib_test/qcheck2_helpers.mli @@ -151,6 +151,13 @@ val sublist : 'a list -> 'a list QCheck2.Gen.t this generator can produce [], [0], [0, 2], [1, 2], [1], etc. *) val holey : 'a list -> 'a list QCheck2.Gen.t +(** [of_option_gen gen] converts a generator [gen] of optional values into a + generator of values by rerunning the generator if the generated value + was a [None] until a [Some] is generated. + + Be careful: if [None] is always returned, this hangs forever! *) +val of_option_gen : 'a option QCheck2.Gen.t -> 'a QCheck2.Gen.t + (** Map-related generators. *) module MakeMapGen (Map : sig type 'a t diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml index 6df79e0a3707..ea3ce8c3963a 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.ml @@ -24,7 +24,7 @@ (*****************************************************************************) open Liquidity_baking_machine -open QCheck.Gen +open QCheck2.Gen open Lib_test let total_xtz = 32_000_000_000_000L @@ -40,23 +40,21 @@ let rec remove_last_element = function list. The elements themselves are not shrinked. *) -let shrink_list_spine_tail : 'a list QCheck.Shrink.t = - let rec shrinked_list = function - | [] -> [] - | l -> - let l = remove_last_element l in - l :: shrinked_list l - in - fun l -> QCheck.Iter.of_list (shrinked_list l) +let rec shrink_list l = + if l == [] then Seq.empty + else + let l = remove_last_element l in + Seq.cons l (shrink_list l) -let gen_balances : int64 -> int -> int -> balances QCheck.Gen.t = +let gen_balances : int64 -> int -> int -> balances QCheck2.Gen.t = fun max_xtz max_tzbtc max_liquidity -> - let+ xtz = Qcheck_helpers.int64_strictly_positive_gen max_xtz - and+ tzbtc = Qcheck_helpers.int_strictly_positive_gen max_tzbtc - and+ liquidity = Qcheck_helpers.int_strictly_positive_gen max_liquidity in + let open Qcheck2_helpers in + let+ xtz = int64_strictly_positive_gen max_xtz + and+ tzbtc = int_strictly_positive_gen max_tzbtc + and+ liquidity = int_strictly_positive_gen max_liquidity in {xtz; tzbtc; liquidity} -let gen_specs : int -> int -> specs QCheck.Gen.t = +let gen_specs : int -> int -> specs QCheck2.Gen.t = fun total_tzbtc total_liquidity -> (* 1. We pick a random number to decide how many implicit account we will set-up in the specs. Note that there will be one more @@ -87,13 +85,7 @@ let gen_specs : int -> int -> specs QCheck.Gen.t = accounts_balances; } -let arb_specs : tzbtc -> liquidity -> specs QCheck.arbitrary = - fun total_tzbtc total_liquidity -> - QCheck.make - ~print:(fun specs -> Format.asprintf "%a" pp_specs specs) - (gen_specs total_tzbtc total_liquidity) - -type 'a optgen = 'a option QCheck.Gen.t +type 'a optgen = 'a option QCheck2.Gen.t let ( let*? ) (m : 'a optgen) (f : 'a -> 'b optgen) = let* x = m in @@ -108,7 +100,7 @@ let ( let*? ) (m : 'a optgen) (f : 'a -> 'b optgen) = whole list (at most 100 times). If no generator of [l] is able to return a result, then [genopt_oneof l] returns [None]. *) let genopt_oneof (l : 'a optgen list) : 'a optgen = - let* l = QCheck.Gen.shuffle_l l in + let* l = QCheck2.Gen.shuffle_l l in let rec aux n = function | [] -> if n = 0 then pure None else aux (n - 1) l | g :: l -> ( @@ -153,7 +145,7 @@ let genopt_step_tzbtc_to_xtz : let*? source = genopt_account_with_tzbtc ?choice:source env state in let*? destination = genopt_account ?choice:destination env in let+ tzbtc_deposit = - Qcheck_helpers.int_strictly_positive_gen + Qcheck2_helpers.int_strictly_positive_gen (SymbolicMachine.get_tzbtc_balance source env state) in (* See note (2) *) @@ -206,7 +198,7 @@ let genopt_step_add_liquidity : (* the source needs at least one xtz *) if 1L < source_xtz_pool then let+ candidate = - Qcheck_helpers.int64_strictly_positive_gen source_xtz_pool + Qcheck2_helpers.int64_strictly_positive_gen source_xtz_pool in let xtz_deposit = find_xtz_deposit @@ -253,26 +245,34 @@ let genopt_step : genopt_step_remove_liquidity env state ?source ?destination; ] -let rec gen_steps : +let gen_steps : ?source:contract_id -> ?destination:contract_id -> contract_id env -> SymbolicMachine.t -> int -> - contract_id step list QCheck.Gen.t = + contract_id step list QCheck2.Gen.t = fun ?source ?destination env state size -> - if size <= 0 then return [] - else - let* h = genopt_step ?source ?destination env state in - match h with - | None -> pure [] - | Some h -> - let state = SymbolicMachine.step h env state in - let* rst = gen_steps ?source ?destination env state (size - 1) in - pure (h :: rst) + let rec inner env state size random_state = + if size <= 0 then [] + else + let h = + QCheck2.Gen.generate1 + ~rand:random_state + (genopt_step ?source ?destination env state) + in + match h with + | None -> [] + | Some h -> + let state = SymbolicMachine.step h env state in + let rst = inner env state (size - 1) random_state in + h :: rst + in + QCheck2.Gen.make_primitive ~gen:(inner env state size) ~shrink:(fun l -> + shrink_list l) let gen_scenario : - tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck.Gen.t = + tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck2.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in let state, env = SymbolicMachine.build specs in @@ -292,24 +292,13 @@ let pp_scenario fmt (specs, steps) = (pp_step pp_contract_id)) steps) -let arb_scenario : - tzbtc -> - liquidity -> - int -> - (specs * contract_id step list) QCheck.arbitrary = - fun total_tzbtc total_liquidity size -> - QCheck.make - ~print:(Format.asprintf "%a" pp_scenario) - ~shrink:(fun (specs, steps) -> - (* See note (1) *) - QCheck.Iter.pair (QCheck.Iter.return specs) (shrink_list_spine_tail steps)) - (gen_scenario total_tzbtc total_liquidity size) +let print_scenario = Format.asprintf "%a" pp_scenario let gen_adversary_scenario : tzbtc -> liquidity -> int -> - (specs * contract_id * contract_id step list) QCheck.Gen.t = + (specs * contract_id * contract_id step list) QCheck2.Gen.t = fun total_tzbtc total_liquidity size -> let* specs = gen_specs total_tzbtc total_liquidity in let state, env = SymbolicMachine.build ~subsidy:0L specs in @@ -317,22 +306,8 @@ let gen_adversary_scenario : let+ scenario = gen_steps ~source:c ~destination:c env state size in (specs, c, scenario) -let arb_adversary_scenario : - tzbtc -> - liquidity -> - int -> - (specs * contract_id * contract_id step list) QCheck.arbitrary = - fun total_tzbtc total_liquidity size -> - QCheck.make - ~print:(fun (specs, _, steps) -> - Format.asprintf "%a" pp_scenario (specs, steps)) - ~shrink:(fun (specs, c, steps) -> - (* see note (1) *) - QCheck.Iter.triple - (QCheck.Iter.return specs) - (QCheck.Iter.return c) - (shrink_list_spine_tail steps)) - (gen_adversary_scenario total_tzbtc total_liquidity size) +let print_adversary_scenario (specs, _, steps) = + Format.asprintf "%a" pp_scenario (specs, steps) (* -------------------------------------------------------------------------- *) @@ -341,7 +316,9 @@ let arb_adversary_scenario : We shrink a valid scenario by removing steps from its tails, because a prefix of a valid scenario remains a valid scenario. Removing a random element of a scenario could lead to an - invalid scenario. *) + invalid scenario. We have to use QCheck2.Gen.make_primitive to specify + the shrinking method of the generator, and avoid defaulting on the + shrinking implied by QCheck2.Gen.bind *) (* Note (2) diff --git a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.mli b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.mli index c0f1a9811438..1f57114240bd 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.mli +++ b/src/proto_alpha/lib_protocol/test/helpers/liquidity_baking_generator.mli @@ -39,39 +39,48 @@ [Liquidity_baking_machine.specs]), along with [build] functions that turn a description of a context into concrete states. - In this module, we provide QCheck generators which allow to + In this module, we provide QCheck2 generators which allow to construct arbitrary specifications for states, and so-called scenarios ({i i.e.}, sequences of entrypoint calls). *) open Liquidity_baking_machine -(** [arb_specs max_tzbtc max_liquidity] constructs arbitrary Liquidity +(** [gen_specs max_tzbtc max_liquidity] constructs arbitrary Liquidity Baking [specs] for an initial state, where at most [max_tzbtc] and [max_liquidity] are shared among an arbitrary number of implicit accounts. *) -val arb_specs : tzbtc -> liquidity -> specs QCheck.arbitrary +val gen_specs : tzbtc -> liquidity -> specs QCheck2.Gen.t -(** [arb_scenario max_tzbtc max_liquidity size] constructs arbitrary - Liquidity Baking [specs] with a semantics similar to [arb_specs], along with sequences of {b valid} +(** [gen_scenario max_tzbtc max_liquidity size] constructs arbitrary + Liquidity Baking [specs] with a semantics similar to [gen_specs], along with sequences of {b valid} scenarios ({i i.e.}, sequences of entrypoint calls) of length [size]. By valid, we mean that running the scenario using a Liquidity baking machine initialized with the [specs] should succeed. *) -val arb_scenario : - tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck.arbitrary +val gen_scenario : + tzbtc -> liquidity -> int -> (specs * contract_id step list) QCheck2.Gen.t -(** [arb_adversary_scenario max_tzbtc max_liquidity size] constructs +(** [print_scenario scenario] produces a string representation of [scenario], + as produced by [gen_scenario]. *) +val print_scenario : specs * contract_id step list -> string + +(** [gen_adversary_scenario max_tzbtc max_liquidity size] constructs arbitrary scenarios that can be used to challenge the “no global gain” property of Liquidity Baking. The key idea of this property is the following: a given contract cannot profit from Liquidity Baking if they are the only one to interact with the CPMM (in the absence of subsidies). The scenario - generated by [arb_adversary_scenario] only consists in [step] + generated by [gen_adversary_scenario] only consists in [step] performed by one contract. This contract is identified by the [contract_id] returned by this function. *) -val arb_adversary_scenario : +val gen_adversary_scenario : tzbtc -> liquidity -> int -> - (specs * contract_id * contract_id step list) QCheck.arbitrary + (specs * contract_id * contract_id step list) QCheck2.Gen.t + +(** [print_adversary_scenario scenario] produces a string representation of [scenario], + as produced by [gen_adversary_scenario]. *) +val print_adversary_scenario : + specs * contract_id * contract_id step list -> string diff --git a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml index 0ed65437d821..915a57c0b537 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/test_global_constants.ml @@ -62,7 +62,7 @@ let assert_ok = function (** Filters out values that would cause [register] *) let assume_expr_not_too_large expr = let node = root expr in - QCheck.assume @@ not + QCheck2.assume @@ not @@ Global_constants_storage.Internal_for_tests.node_too_large node module Generators = struct diff --git a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml index bf31e359f89e..dffa2bd2d312 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -40,7 +40,7 @@ open Liquidity_baking_machine ValidationMachine} too) is slow, we implement the following test-suit architecture: - - One {v QCheck v}-based test is used to validate consistency of + - One {v QCheck2 v}-based test is used to validate consistency of the {! SymbolicMachine} wrt. the [ConcreteMachine], thanks to the {! ValidationMachine}. - The rest of the tests use the {! SymbolicMachine} in order to be @@ -54,7 +54,7 @@ let extract_qcheck_tzresult : unit tzresult Lwt.t -> bool = fun p -> match Lwt_main.run p with | Ok () -> true - | Error err -> QCheck.Test.fail_reportf "@\n%a@." pp_print_trace err + | Error err -> QCheck2.Test.fail_reportf "@\n%a@." pp_print_trace err let rec run_and_check check scenarios env state = match scenarios with @@ -219,30 +219,33 @@ let validate_storage : themselves. *) let machine_validation_tests = [ - QCheck.Test.make + QCheck2.Test.make ~count:10 ~name:"Concrete/Symbolic Consistency" - (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 10) + ~print:Liquidity_baking_generator.print_scenario + (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 10) (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = validate_consistency in ValidationMachine.build ~invariant specs >>=? fun (state, env) -> ValidationMachine.run ~invariant scenario env state >>=? fun _ -> return_unit)); - QCheck.Test.make + QCheck2.Test.make ~count:10 ~name:"Storage consistency" - (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 10) + ~print:Liquidity_baking_generator.print_scenario + (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 10) (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = validate_storage in ConcreteMachine.build ~invariant specs >>=? fun (state, env) -> ConcreteMachine.run ~invariant scenario env state >>=? fun _ -> return_unit)); - QCheck.Test.make + QCheck2.Test.make ~count:100_000 ~name:"Positive pools" - (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) + ~print:Liquidity_baking_generator.print_scenario + (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> extract_qcheck_tzresult (let invariant = positive_pools in @@ -256,30 +259,33 @@ let machine_validation_tests = feature. *) let economic_tests = [ - QCheck.Test.make + QCheck2.Test.make ~count:100_000 ~name:"No global gain" - (Liquidity_baking_generator.arb_adversary_scenario 1_000_000 1_000_000 50) + ~print:Liquidity_baking_generator.print_adversary_scenario + (Liquidity_baking_generator.gen_adversary_scenario 1_000_000 1_000_000 50) (fun (specs, attacker, scenario) -> let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (one_balance_decreases attacker env) scenario env state in true); - QCheck.Test.make + QCheck2.Test.make ~count:100_000 ~name:"Remove liquidities is consistent" - (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) + ~print:Liquidity_baking_generator.print_scenario + (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = run_and_check (is_remove_liquidity_consistent env) scenario env state in true); - QCheck.Test.make + QCheck2.Test.make ~count:100_000 ~name:"Share price only increases" - (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) + ~print:Liquidity_baking_generator.print_scenario + (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> let state, env = SymbolicMachine.build ~subsidy:0L specs in let _ = @@ -289,7 +295,7 @@ let economic_tests = ] let _ = - let open Lib_test.Qcheck_helpers in + let open Lib_test.Qcheck2_helpers in Alcotest.run "protocol > pbt > liquidity baking" [ diff --git a/src/proto_alpha/lib_protocol/test/pbt/saturation_fuzzing.ml b/src/proto_alpha/lib_protocol/test/pbt/saturation_fuzzing.ml index f44a036ab5f9..4a7fd692473c 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/saturation_fuzzing.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/saturation_fuzzing.ml @@ -32,23 +32,23 @@ *) open Protocol.Saturation_repr -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (** A generator that returns a [t] that cannot be [saturated] *) -let unsatured_arb = of_option_arb @@ QCheck.map of_int_opt QCheck.int +let unsatured_gen = of_option_gen @@ QCheck2.Gen.(map of_int_opt int) (** The general generator for [t]: generates both unsaturated values and [saturated]. *) -let t_arb : may_saturate t QCheck.arbitrary = - QCheck.frequency [(1, QCheck.always saturated); (4, unsatured_arb)] +let t_gen : may_saturate t QCheck2.Gen.t = + QCheck2.Gen.(frequency [(1, return saturated); (4, unsatured_gen)]) (* Test. * Tests that [add] commutes. *) let test_add_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 = t2 + t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in let t2_plus_t1 = add t2 t1 in @@ -58,9 +58,9 @@ let test_add_commutes = * Tests that [mul] commutes. *) let test_mul_commutes = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 * t2 = t2 * t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let t1_times_t2 = mul t1 t2 in let t2_times_t1 = mul t2 t1 in @@ -70,7 +70,7 @@ let test_mul_commutes = * Tests that [zero] is neutral for [add]. *) let test_add_zero = - QCheck.Test.make ~name:"t + 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t + 0 = t" t_gen (fun t -> let t_plus_zero = add t zero in qcheck_eq' ~pp ~expected:t ~actual:t_plus_zero ()) @@ -78,9 +78,9 @@ let test_add_zero = * Tests that t1 + t2 >= t1 *) let test_add_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let t1_plus_t2 = add t1 t2 in t1_plus_t2 >= t1) @@ -90,7 +90,7 @@ let test_add_neq = *) let test_mul_one = let one = safe_int 1 in - QCheck.Test.make ~name:"t * 1 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 1 = t" t_gen (fun t -> let t_times_one = mul t one in qcheck_eq' ~pp ~expected:t ~actual:t_times_one ()) @@ -98,7 +98,7 @@ let test_mul_one = * Tests that [t] times [0] equals [0]. *) let test_mul_zero = - QCheck.Test.make ~name:"t * 0 = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t * 0 = 0" t_gen (fun t -> let t_times_zero = mul t zero in qcheck_eq' ~pp ~expected:zero ~actual:t_times_zero ()) @@ -106,7 +106,7 @@ let test_mul_zero = * Tests that [t] [sub] [zero] equals [t]. *) let test_sub_zero = - QCheck.Test.make ~name:"t - 0 = t" t_arb (fun t -> + QCheck2.Test.make ~name:"t - 0 = t" t_gen (fun t -> let t_sub_zero = sub t zero in qcheck_eq' ~pp ~expected:t ~actual:t_sub_zero ()) @@ -114,7 +114,7 @@ let test_sub_zero = * Tests that [t] [sub] [t] equals [zero]. *) let test_sub_itself = - QCheck.Test.make ~name:"t - t = 0" t_arb (fun t -> + QCheck2.Test.make ~name:"t - t = 0" t_gen (fun t -> let t_sub_t = sub t t in qcheck_eq' ~pp ~expected:zero ~actual:t_sub_t ()) @@ -122,9 +122,9 @@ let test_sub_itself = * Tests that t1 - t2 <= t1 *) let test_sub_neq = - QCheck.Test.make + QCheck2.Test.make ~name:"t1 - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let t1_minus_t2 = sub t1 t2 in t1_minus_t2 <= t1) @@ -133,9 +133,9 @@ let test_sub_neq = * Tests that (t1 + t2) - t2 <= t1 *) let test_add_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 + t2) - t2 <= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let lhs = sub (add t1 t2) t2 in lhs <= t1) @@ -144,9 +144,9 @@ let test_add_sub = * Tests that (t1 - t2) + t2 >= t1 *) let test_sub_add = - QCheck.Test.make + QCheck2.Test.make ~name:"(t1 - t2) + t2 >= t1" - (QCheck.pair t_arb t_arb) + (QCheck2.Gen.pair t_gen t_gen) (fun (t1, t2) -> let lhs = add (sub t1 t2) t2 in lhs >= t1) @@ -155,25 +155,25 @@ let test_sub_add = * Tests that [saturated] >= t *) let test_leq_saturated = - QCheck.Test.make ~name:"t <= saturated" t_arb (fun t -> saturated >= t) + QCheck2.Test.make ~name:"t <= saturated" t_gen (fun t -> saturated >= t) (* Test. * Tests that [zero] <= t *) -let test_geq_zero = QCheck.Test.make ~name:"t >= 0" t_arb (fun t -> zero <= t) +let test_geq_zero = QCheck2.Test.make ~name:"t >= 0" t_gen (fun t -> zero <= t) (* Test. * Tests that [sqrt (t * t) = t] *) let test_squared_sqrt = - QCheck.Test.make ~name:"sqrt t² = t" t_arb (fun t -> + QCheck2.Test.make ~name:"sqrt t² = t" t_gen (fun t -> mul t t = saturated || sqrt (mul t t) = t) (* Test. * Tests that [(sqrt t) * (sqrt t) <= t] *) let test_sqrt_squared = - QCheck.Test.make ~name:"(sqrt t)² <= t <= (succ (sqrt t))²" t_arb (fun t -> + QCheck2.Test.make ~name:"(sqrt t)² <= t <= (succ (sqrt t))²" t_gen (fun t -> mul (sqrt t) (sqrt t) <= t && t <= mul (succ (sqrt t)) (succ (sqrt t))) let tests_add = [test_add_commutes; test_add_zero; test_add_neq] diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml index 6b20dc8c4d63..f41a81928f96 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_carbonated_map.ml @@ -31,7 +31,7 @@ Subject: Operations in Carbonated_map *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers open QCheck2 open Protocol diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml index 13809ed741db..d6e766b8d51e 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_gas_properties.ml @@ -32,9 +32,9 @@ *) open Protocol -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers -(** Extract a Tezos result for compatibility with QCheck. *) +(** Extract a Tezos result for compatibility with QCheck2. *) let extract_qcheck_result = function | Ok pure_result -> pure_result | Error err -> @@ -88,8 +88,8 @@ let test_consume_commutes (start, cost1, cost2) = (Gas.consumed ~since:start ~until:branch2)) ) (** Arbitrary context with a gas limit of 100_000_000. *) -let context_arb : Alpha_context.t QCheck.arbitrary = - QCheck.always +let context_gen : Alpha_context.t QCheck2.Gen.t = + QCheck2.Gen.return (Lwt_main.run ( Context.init1 () >>=? fun (b, _contract) -> Incremental.begin_construction b >|=? fun inc -> @@ -102,12 +102,12 @@ let context_arb : Alpha_context.t QCheck.arbitrary = | Error _ -> assert false) (** This arbitrary could be improved (pretty printer and shrinker) if there was a way to convert a [cost] back to an [int]. Otherwise one needs to write a custom [arbitrary] instance, but I wanted to stick to the former design of this test for the time being. *) -let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = +let gas_cost_gen : Alpha_context.Gas.cost QCheck2.Gen.t = let open Alpha_context.Gas in - let open QCheck in + let open QCheck2.Gen in let rand = 0 -- 1000 in let safe_rand = map Saturation_repr.safe_int rand in - choose + oneof [ map atomic_step_cost safe_rand; map step_cost safe_rand; @@ -120,20 +120,20 @@ let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = let tests = [ - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming commutes" - QCheck.(triple context_arb gas_cost_arb gas_cost_arb) + QCheck2.Gen.(triple context_gen gas_cost_gen gas_cost_gen) test_consume_commutes; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"Consuming [free] consumes nothing" - context_arb + context_gen test_free_consumption; - QCheck.Test.make + QCheck2.Test.make ~count:1000 ~name:"[free] is the neutral element of Gas addition" - QCheck.(pair context_arb gas_cost_arb) + QCheck2.Gen.(pair context_gen gas_cost_gen) test_free_neutral; ] diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index 9c67fc7a7e1c..110a62bb0f87 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -36,8 +36,7 @@ open Protocol open Alpha_context open Sc_rollup open Lwt_syntax -open Lib_test.Qcheck_helpers -module Sc_rollup_repr = Protocol.Sc_rollup_repr +open Lib_test.Qcheck2_helpers (** diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml b/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml index b6cab4985567..5d77d2f35b9a 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_sampler.ml @@ -31,7 +31,7 @@ Subject: Operations in Saturation_repr *) -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers open Protocol.Sampler (* ------------------------------------------------------------------------- *) @@ -180,7 +180,7 @@ struct let error = linf empirical truth in let max_error = 0.001 *. Mass.to_float total_mass in if not Q.(error < Q.of_float max_error) then - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "didn't converge (%f)@.%a" (Q.to_float error) (pp_dist Format.pp_print_int) @@ -250,20 +250,18 @@ module Test_z = let qcheck_wrap = qcheck_wrap ~rand:state let alias_float_test = - QCheck.Test.make + QCheck2.Test.make ~count:100 ~name:"alias_float" - QCheck.(list_of_size (Gen.int_range 1 20) pos_float) + QCheck2.Gen.(list_size (int_range 1 20) pfloat) Test_float.make let alias_z_test = - QCheck.Test.make + QCheck2.Test.make ~count:100 ~name:"alias_z" - QCheck.( - list_of_size - (Gen.int_range 1 20) - (make Gen.(nat >>= fun n -> return (Z.of_int n)))) + QCheck2.Gen.( + list_size (int_range 1 20) (nat >>= fun n -> return (Z.of_int n))) Test_z.make let () = diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml index e61e824d9d56..d9d7a5851dc6 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_tick_repr.ml @@ -106,4 +106,4 @@ let tests = let () = Alcotest.run "Tick_repr" - [("Tick_repr", Lib_test.Qcheck_helpers.qcheck_wrap tests)] + [("Tick_repr", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml index 39dccc705269..ce5313b77904 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_script_comparison.ml @@ -34,7 +34,7 @@ open Protocol open Alpha_context open Script_typed_ir -open Lib_test.Qcheck_helpers +open Lib_test.Qcheck2_helpers (* Reference implementation *) @@ -93,7 +93,7 @@ type ex_comparable_data_3 = 'a comparable_ty * 'a * 'a * 'a -> ex_comparable_data_3 -(* We use the Michelson samplers from lib_benchmark and turn them into QCheck +(* We use the Michelson samplers from lib_benchmark and turn them into QCheck2 generators *) module Parameters = struct let atom_size_range : Tezos_benchmark.Base_samplers.range = @@ -170,23 +170,17 @@ let ex_comparable_data_3_sampler : let z = Samplers.Random_value.comparable ty random_state in Ex_comparable_data_3 (ty, x, y, z) -let comparable_data_generator : ex_comparable_data QCheck.Gen.t = - ex_comparable_data_sampler +let comparable_data_generator = + QCheck2.Gen.make_primitive ~gen:ex_comparable_data_sampler ~shrink:(fun _ -> + Seq.empty) -let comparable_data_2_generator : ex_comparable_data_2 QCheck.Gen.t = - ex_comparable_data_2_sampler +let comparable_data_2_generator = + QCheck2.Gen.make_primitive ~gen:ex_comparable_data_2_sampler ~shrink:(fun _ -> + Seq.empty) -let comparable_data_3_generator : ex_comparable_data_3 QCheck.Gen.t = - ex_comparable_data_3_sampler - -let comparable_data_arbitrary : ex_comparable_data QCheck.arbitrary = - QCheck.make comparable_data_generator - -let comparable_data_2_arbitrary : ex_comparable_data_2 QCheck.arbitrary = - QCheck.make comparable_data_2_generator - -let comparable_data_3_arbitrary : ex_comparable_data_3 QCheck.arbitrary = - QCheck.make comparable_data_3_generator +let comparable_data_3_generator = + QCheck2.Gen.make_primitive ~gen:ex_comparable_data_3_sampler ~shrink:(fun _ -> + Seq.empty) (* We need a context because packing (used in one of the tests) and unparsing (used for pretty-printing error messages) Michelson data are carbonated @@ -257,9 +251,9 @@ let qcheck_compare_comparable_eq ~expected ty x y = * implementation. *) let test_compatible_with_reference = - QCheck.Test.make + QCheck2.Test.make ~name:"compatible_with_reference" - comparable_data_2_arbitrary + comparable_data_2_generator (fun (Ex_comparable_data_2 (ty, x, y)) -> qcheck_compare_comparable ~expected:(reference_compare_comparable ty x y) @@ -272,9 +266,9 @@ let test_compatible_with_reference = * resulting bytes returns 0. *) let test_compatible_with_packing = - QCheck.Test.make + QCheck2.Test.make ~name:"compatible_with_packing" - comparable_data_2_arbitrary + comparable_data_2_generator (fun (Ex_comparable_data_2 (ty, x, y)) -> qcheck_compare_comparable_eq ~expected:(compare_through_pack ty x y) @@ -286,9 +280,9 @@ let test_compatible_with_packing = * Tests that compare_comparable is reflexive. *) let test_reflexivity = - QCheck.Test.make + QCheck2.Test.make ~name:"reflexivity" - comparable_data_arbitrary + comparable_data_generator (fun (Ex_comparable_data (ty, x)) -> qcheck_compare_comparable ~expected:0 ty x x) @@ -296,9 +290,9 @@ let test_reflexivity = * Tests that compare_comparable is symmetric. *) let test_symmetry = - QCheck.Test.make + QCheck2.Test.make ~name:"symmetry" - comparable_data_2_arbitrary + comparable_data_2_generator (fun (Ex_comparable_data_2 (ty, x, y)) -> qcheck_compare_comparable ~expected:(-Script_comparable.compare_comparable ty x y) @@ -310,9 +304,9 @@ let test_symmetry = * Tests that compare_comparable is transitive. *) let test_transitivity = - QCheck.Test.make + QCheck2.Test.make ~name:"transitivity" - comparable_data_3_arbitrary + comparable_data_3_generator (fun (Ex_comparable_data_3 (ty, x, y, z)) -> let cxy = Script_comparable.compare_comparable ty x y in let cyz = Script_comparable.compare_comparable ty y z in @@ -320,13 +314,13 @@ let test_transitivity = | 0, n | n, 0 -> qcheck_compare_comparable ~expected:n ty x z | -1, -1 -> qcheck_compare_comparable ~expected:(-1) ty x z | 1, 1 -> qcheck_compare_comparable ~expected:1 ty x z - | _ -> QCheck.assume_fail ()) + | _ -> QCheck2.assume_fail ()) (* Test. * Tests the round-trip property for PACK and UNPACK (modulo compare_comparable). *) let test_pack_unpack = - QCheck.Test.make + QCheck2.Test.make ~count:100_000 (* We run this test on many more cases than the default (100) because this is a very important property. Packing and then unpacking happens each @@ -336,7 +330,7 @@ let test_pack_unpack = direct consequence of this) is an important property for big maps (because the keys are packed and then hashed). *) ~name:"pack_unpack" - comparable_data_arbitrary + comparable_data_generator (fun (Ex_comparable_data (ty, x)) -> let oty = match comparable_option_t (-1) ty with diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml b/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml index 621511c0a4c3..035bff33e6db 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_tez_repr.ml @@ -46,16 +46,16 @@ let z_in_mutez_bounds (z : Z.t) : bool = let compare (c' : Z.t) (c : Tez.t tzresult) : bool = match (z_in_mutez_bounds @@ c', c) with | true, Ok c -> - Lib_test.Qcheck_helpers.qcheck_eq' + Lib_test.Qcheck2_helpers.qcheck_eq' ~pp:Z.pp_print ~expected:c' ~actual:(tez_to_z c) () | true, Error _ -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are in Z bounds, but tez operation fails.@]" | false, Ok _ -> - QCheck.Test.fail_reportf + QCheck2.Test.fail_reportf "@[Results are not in Z bounds, but tez operation did not fail.@]" | false, Error _ -> true @@ -75,61 +75,56 @@ let prop_binop64 (f : Tez.t -> int64 -> Tez.t tzresult) (f' : Z.t -> Z.t -> Z.t) ((a, b) : Tez.t * int64) : bool = compare (f' (tez_to_z a) (Z.of_int64 b)) (f a b) -(** Arbitrary int64 by conversion from int32 *) -let arb_int64_of32 : int64 QCheck.arbitrary = - QCheck.(map ~rev:Int64.to_int32 Int64.of_int32 int32) +(** Generator for int64 by conversion from int32 *) +let gen_int64_of32 : int64 QCheck2.Gen.t = + QCheck2.Gen.(map Int64.of_int32 int32) -(** Arbitrary int64 mixing small positive integers, +(** Generator for int64 mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_int64_sizes : int64 QCheck.arbitrary = - let open QCheck in - oneof - [ - QCheck.map ~rev:Int64.to_int Int64.of_int (int_range (-10) 10); - arb_int64_of32; - int64; - ] - -(** Arbitrary positive int64, mixing small positive integers, +let gen_int64_sizes : int64 QCheck2.Gen.t = + let open QCheck2.Gen in + oneof [map Int64.of_int (int_range (-10) 10); gen_int64_of32; int64] + +(** Generator for positive int64, mixing small positive integers, int64s from int32 and arbitrary int64 with equal frequency *) -let arb_ui64_sizes : int64 QCheck.arbitrary = - let open QCheck in - map_same_type +let gen_ui64_sizes : int64 QCheck2.Gen.t = + let open QCheck2.Gen in + map (fun i -> let v = if i = Int64.min_int then Int64.max_int else Int64.abs i in assert (v >= 0L) ; v) - arb_int64_sizes + gen_int64_sizes -(** Arbitrary tez based on [arb_tez_sizes] *) -let arb_tez_sizes = - let open QCheck in - map ~rev:Tez.to_mutez Tez.of_mutez_exn arb_ui64_sizes +(** Generator for tez based on [gen_tez_sizes] *) +let gen_tez_sizes = + let open QCheck2.Gen in + map Tez.of_mutez_exn gen_ui64_sizes let test_coherent_mul = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(*?) is coherent w.r.t. Z.(*)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (prop_binop64 ( *? ) Z.( * )) let test_coherent_sub = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(-?) is coherent w.r.t. Z.(-)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop ( -? ) Z.( - )) let test_coherent_add = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(+?) is coherent w.r.t. Z.(+)" - QCheck.(pair arb_tez_sizes arb_tez_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_tez_sizes) (prop_binop ( +? ) Z.( + )) let test_coherent_div = - QCheck.Test.make + QCheck2.Test.make ~name:"Tez.(/?) is coherent w.r.t. Z.(/)" - QCheck.(pair arb_tez_sizes arb_ui64_sizes) + QCheck2.Gen.(pair gen_tez_sizes gen_ui64_sizes) (fun (a, b) -> - QCheck.assume (b > 0L) ; + QCheck2.assume (b > 0L) ; prop_binop64 ( /? ) Z.( / ) (a, b)) let tests = @@ -138,4 +133,4 @@ let tests = let () = Alcotest.run "protocol > pbt > tez_repr" - [("Tez_repr", Lib_test.Qcheck_helpers.qcheck_wrap tests)] + [("Tez_repr", Lib_test.Qcheck2_helpers.qcheck_wrap tests)] -- GitLab From c98f344d3c7a0634c38dbc14bb15972d0a481a7c Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Thu, 19 May 2022 18:20:39 +0200 Subject: [PATCH 5/7] Proto_alpha/lib_protocol/test/pbt: reduce number of tests This commit reduces the numer of tests to alleviate the runtime increase caused by the migration from QCheck to QCheck2. --- .../lib_protocol/test/pbt/liquidity_baking_pbt.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml index dffa2bd2d312..4dbf3dc3b242 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -242,7 +242,7 @@ let machine_validation_tests = ConcreteMachine.run ~invariant scenario env state >>=? fun _ -> return_unit)); QCheck2.Test.make - ~count:100_000 + ~count:50_000 ~name:"Positive pools" ~print:Liquidity_baking_generator.print_scenario (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) @@ -260,7 +260,7 @@ let machine_validation_tests = let economic_tests = [ QCheck2.Test.make - ~count:100_000 + ~count:50_000 ~name:"No global gain" ~print:Liquidity_baking_generator.print_adversary_scenario (Liquidity_baking_generator.gen_adversary_scenario 1_000_000 1_000_000 50) @@ -271,7 +271,7 @@ let economic_tests = in true); QCheck2.Test.make - ~count:100_000 + ~count:50_000 ~name:"Remove liquidities is consistent" ~print:Liquidity_baking_generator.print_scenario (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) @@ -282,7 +282,7 @@ let economic_tests = in true); QCheck2.Test.make - ~count:100_000 + ~count:50_000 ~name:"Share price only increases" ~print:Liquidity_baking_generator.print_scenario (Liquidity_baking_generator.gen_scenario 1_000_000 1_000_000 50) -- GitLab From c927d1ae3bc43df075b99e885d6591f5656bdbc7 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 23 May 2022 10:56:41 +0200 Subject: [PATCH 6/7] Proto_alpha/lib_client: migrate to QCheck2 --- src/proto_alpha/lib_client/test/test_proxy.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_client/test/test_proxy.ml b/src/proto_alpha/lib_client/test/test_proxy.ml index 273102db51e5..9db20d29907e 100644 --- a/src/proto_alpha/lib_client/test/test_proxy.ml +++ b/src/proto_alpha/lib_client/test/test_proxy.ml @@ -85,4 +85,4 @@ let test_split_key = let () = Alcotest.run "tezos-lib-client-proxy" - [("proxy", Lib_test.Qcheck_helpers.qcheck_wrap [test_split_key])] + [("proxy", Lib_test.Qcheck2_helpers.qcheck_wrap [test_split_key])] -- GitLab From 4df2fb197781b0eeceeda21ac0571ab7cb2cbc22 Mon Sep 17 00:00:00 2001 From: Nicolas BACQUEY Date: Mon, 23 May 2022 14:35:41 +0200 Subject: [PATCH 7/7] Tezt/long_tests: migrate to QCheck2 This migration is made necessary by the fact that some tests in `qcheck_rpc.ml` depend on `proto_alpha/`. --- tezt/long_tests/qcheck_rpc.ml | 36 +++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/tezt/long_tests/qcheck_rpc.ml b/tezt/long_tests/qcheck_rpc.ml index e7f094c94004..9585d2519e98 100644 --- a/tezt/long_tests/qcheck_rpc.ml +++ b/tezt/long_tests/qcheck_rpc.ml @@ -295,13 +295,13 @@ end (* Generate random data for RPC calls *) (* ------------------------------------------------------------------------- *) module Gen = struct - type 'a t = 'a QCheck.Gen.t + type 'a t = 'a QCheck2.Gen.t (* Prerequisites of [path_gen] *) (* ---------------------------- *) let chain_id_gen : string t = - let open QCheck.Gen in + let open QCheck2.Gen in let open Tezos_crypto in let non_alias = list string >|= Chain_id.hash_string >|= Chain_id.to_string @@ -309,7 +309,7 @@ module Gen = struct frequency [(4, pure "main"); (2, pure "test"); (1, non_alias)] let block_hash_gen : string t = - let open QCheck.Gen in + let open QCheck2.Gen in let open Tezos_crypto in let non_alias = list string >|= Block_hash.hash_string >|= Block_hash.to_string @@ -317,11 +317,11 @@ module Gen = struct frequency [(4, pure "head"); (2, pure "genesis"); (1, non_alias)] let protocol_hash_gen : string t = - let open QCheck.Gen in + let open QCheck2.Gen in let open Tezos_crypto in list string >|= Protocol_hash.hash_string >|= Protocol_hash.to_string - let path_int_gen : string t = QCheck.Gen.(map Int.to_string small_nat) + let path_int_gen : string t = QCheck2.Gen.(map Int.to_string small_nat) (* Prerequisites of [known_input_gen] *) (* ----------------------------------- *) @@ -334,9 +334,9 @@ module Gen = struct nums ^ alpha ^ String.capitalize_ascii alpha |> String.to_seq |> List.of_seq let even_alpha_num_gen : string t = - let alpha_num_gen = QCheck.Gen.oneofl alpha_num_alphabet in - let even_gen = QCheck.Gen.map (( * ) 2) QCheck.Gen.(0 -- 100) in - QCheck.Gen.string_size ~gen:alpha_num_gen even_gen + let alpha_num_gen = QCheck2.Gen.oneofl alpha_num_alphabet in + let even_gen = QCheck2.Gen.map (( * ) 2) QCheck2.Gen.(0 -- 100) in + QCheck2.Gen.string_size ~gen:alpha_num_gen even_gen let rec take n xs : 'a list = match (n, xs) with @@ -345,7 +345,7 @@ module Gen = struct | n, y :: ys -> y :: take (n - 1) ys let pick_some_elems xs : 'a list t = - let open QCheck.Gen in + let open QCheck2.Gen in let shuffle_gen = pair (shuffle_l xs) (0 -- List.length xs) in map (fun (ys, n) -> take n ys) shuffle_gen @@ -354,7 +354,7 @@ module Gen = struct let open Tezos_protocol_alpha.Protocol.Michelson_v1_primitives in let open Tezos_micheline in let open Micheline_encoding in - let open QCheck.Gen in + let open QCheck2.Gen in let l_gen = return (-1) in let annot_gen = return [] in let micheline_node_gen = @@ -369,7 +369,7 @@ module Gen = struct (* ---------------------- *) let path_gen path : string list t = - let open QCheck.Gen in + let open QCheck2.Gen in let path_str_gen = string_size (1 -- 100) in let elem_to_gen : (string, path_input) Either.t -> string t = function | Either.Left s -> pure s @@ -389,7 +389,7 @@ module Gen = struct (* ---------------------------- *) let rec known_input_gen : rpc_input -> Ezjsonm.value t = - let open QCheck.Gen in + let open QCheck2.Gen in function | Boolean -> map Ezjsonm.bool bool | Integer {min; max} -> @@ -411,7 +411,7 @@ module Gen = struct list_size (0 -- 10) (known_input_gen rpc_input) |> map (fun l -> `A l) | One_of rpc_inputs -> oneof @@ List.map known_input_gen rpc_inputs | Object properties -> - let open QCheck.Gen in + let open QCheck2.Gen in List.partition (fun x -> x.required) properties |> fun (req, not_req) -> pick_some_elems not_req >>= fun some_elems -> req @ some_elems @@ -419,18 +419,18 @@ module Gen = struct |> List.split |> fun (names, payloads) -> List.map known_input_gen payloads - |> QCheck.Gen.flatten_l - |> QCheck.Gen.map (fun inputs -> `O (List.combine names inputs)) + |> QCheck2.Gen.flatten_l + |> QCheck2.Gen.map (fun inputs -> `O (List.combine names inputs)) | Mich_exp -> micheline_exp_gen let input_gen opt_rpc_input : Ezjsonm.value option t = - Option.map known_input_gen opt_rpc_input |> QCheck.Gen.flatten_opt + Option.map known_input_gen opt_rpc_input |> QCheck2.Gen.flatten_opt (* Random RPC instance generation *) (* ------------------------------ *) let instance_gen {description; meth; path; data} : rpc_instance t = - let open QCheck.Gen in + let open QCheck2.Gen in pair (input_gen data) (path_gen path) |> map (fun (input, full_path) -> {description; meth; full_path; input}) end @@ -501,7 +501,7 @@ module Test = struct (* Generate and test instances *) let* () = rpc_description |> Gen.instance_gen - |> QCheck.Gen.generate ~n:num_rand_inputs + |> QCheck2.Gen.generate ~n:num_rand_inputs |> Lwt_list.iter_s (test_instance client) in Node.terminate node -- GitLab