From e7126dd93d778811e2179c011d80f43b62fe7e62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 2 Sep 2022 15:22:59 +0200 Subject: [PATCH 1/4] Alpha/tests/pbt: convert from infix syntax to binding operator syntax --- manifest/main.ml | 5 +- src/proto_alpha/lib_protocol/test/pbt/dune | 1 - .../test/pbt/liquidity_baking_pbt.ml | 74 +++++++++++------- .../lib_protocol/test/pbt/test_bitset.ml | 2 +- .../test/pbt/test_carbonated_map.ml | 15 ++-- .../test/pbt/test_gas_properties.ml | 76 ++++++++++--------- .../test/pbt/test_script_comparison.ml | 7 +- 7 files changed, 103 insertions(+), 77 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 04bacd2e27d8..54cb406136c7 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -3513,8 +3513,11 @@ end = struct ~opam:(sf "tezos-protocol-%s-tests" name_dash) ~deps: [ - octez_base |> open_ ~m:"TzPervasives" + octez_base + |> if_ N.(number <= 14) + |> open_ ~m:"TzPervasives" |> open_ ~m:"TzPervasives.Error_monad.Legacy_monad_globals"; + octez_base |> if_ N.(number >= 15) |> open_ ~m:"TzPervasives"; octez_micheline |> open_; client |> if_some |> open_; main |> open_; diff --git a/src/proto_alpha/lib_protocol/test/pbt/dune b/src/proto_alpha/lib_protocol/test/pbt/dune index 06e66e88e924..72a2d61953b6 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/dune +++ b/src/proto_alpha/lib_protocol/test/pbt/dune @@ -34,7 +34,6 @@ (flags (:standard) -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals -open Tezos_micheline -open Tezos_client_alpha -open Tezos_protocol_alpha 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 4dbf3dc3b242..f17af60c8e9a 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 @@ -125,8 +125,9 @@ let positive_pools env state = let validate_xtz_balance : Contract.t -> ValidationMachine.t -> bool tzresult Lwt.t = fun contract state -> - ValidationMachine.Symbolic.get_xtz_balance contract state >>=? fun expected -> - ValidationMachine.Concrete.get_xtz_balance contract state >>=? fun amount -> + let open Lwt_result_syntax in + let* expected = ValidationMachine.Symbolic.get_xtz_balance contract state in + let* amount = ValidationMachine.Concrete.get_xtz_balance contract state in return (amount = expected) (** [validate_tzbtc_balance c env (blk, state)] returns [true] iff the @@ -135,10 +136,14 @@ let validate_xtz_balance : let validate_tzbtc_balance : Contract.t -> Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = fun contract env state -> - ValidationMachine.Symbolic.get_tzbtc_balance contract env state - >>=? fun expected -> - ValidationMachine.Concrete.get_tzbtc_balance contract env state - >>=? fun amount -> return (expected = amount) + let open Lwt_result_syntax in + let* expected = + ValidationMachine.Symbolic.get_tzbtc_balance contract env state + in + let* amount = + ValidationMachine.Concrete.get_tzbtc_balance contract env state + in + return (expected = amount) (** [validate_liquidity_balance c env (blk, state)] returns [true] if the contract [c] holds the same amount of liquidity in [blk] and @@ -146,10 +151,14 @@ let validate_tzbtc_balance : let validate_liquidity_balance : Contract.t -> Contract.t env -> ValidationMachine.t -> bool tzresult Lwt.t = fun contract env state -> - ValidationMachine.Symbolic.get_liquidity_balance contract env state - >>=? fun expected -> - ValidationMachine.Concrete.get_liquidity_balance contract env state - >>=? fun amount -> return (expected = amount) + let open Lwt_result_syntax in + let* expected = + ValidationMachine.Symbolic.get_liquidity_balance contract env state + in + let* amount = + ValidationMachine.Concrete.get_liquidity_balance contract env state + in + return (expected = amount) (** [validate_balances c env (blk, state)] returns true iff the contract [c] holds the same amount of tez, tzbtc and liquidity in @@ -168,10 +177,13 @@ let validate_balances : CPMM has distributed the same amount of liquidity tokens in its concrete and symbolic parts of [state]. *) let validate_cpmm_total_liquidity env state = - ValidationMachine.Concrete.get_cpmm_total_liquidity env state - >>=? fun concrete_cpmm_total_liquidity -> - ValidationMachine.Symbolic.get_cpmm_total_liquidity env state - >>=? fun ghost_cpmm_total_liquidity -> + let open Lwt_result_syntax in + let* concrete_cpmm_total_liquidity = + ValidationMachine.Concrete.get_cpmm_total_liquidity env state + in + let* ghost_cpmm_total_liquidity = + ValidationMachine.Symbolic.get_cpmm_total_liquidity env state + in return (concrete_cpmm_total_liquidity = ghost_cpmm_total_liquidity) (** [validate_consistency env (blk, state)] checks if the accounts in @@ -196,28 +208,32 @@ let validate_consistency : let validate_storage : Contract.t env -> ConcreteMachine.t -> bool tzresult Lwt.t = fun env blk -> - Cpmm_repr.Storage.get (B blk) ~contract:env.cpmm_contract - >>=? fun cpmm_storage -> + let open Lwt_result_syntax in + let* cpmm_storage = + Cpmm_repr.Storage.get (B blk) ~contract:env.cpmm_contract + in all_true [ (* 1. Check the CPMM's [xtzPool] is equal to the actual CPMM balance *) - ( ConcreteMachine.get_xtz_balance env.cpmm_contract blk - >>=? fun cpmm_xtz -> return (cpmm_xtz = Tez.to_mutez cpmm_storage.xtzPool) - ); + (let* cpmm_xtz = ConcreteMachine.get_xtz_balance env.cpmm_contract blk in + return (cpmm_xtz = Tez.to_mutez cpmm_storage.xtzPool)); (* 2. Check the CPMM’s [lqtTotal] is correct wrt. liquidity contract *) - ( Lqt_fa12_repr.Storage.get (B blk) ~contract:env.liquidity_contract - >>=? fun liquidity_storage -> - return (cpmm_storage.lqtTotal = liquidity_storage.totalSupply) ); + (let* liquidity_storage = + Lqt_fa12_repr.Storage.get (B blk) ~contract:env.liquidity_contract + in + return (cpmm_storage.lqtTotal = liquidity_storage.totalSupply)); (* 3. Check the CPMM’s [tokenPool] is correct *) - ( ConcreteMachine.get_tzbtc_balance env.cpmm_contract env blk - >>=? fun cpmm_tzbtc -> - return (Z.to_int cpmm_storage.tokenPool = cpmm_tzbtc) ); + (let* cpmm_tzbtc = + ConcreteMachine.get_tzbtc_balance env.cpmm_contract env blk + in + return (Z.to_int cpmm_storage.tokenPool = cpmm_tzbtc)); ] (** [machine_validation_tests] is a list of asynchronous tests aiming at asserting the correctness and consistencies of the machines themselves. *) let machine_validation_tests = + let open Lwt_result_syntax in [ QCheck2.Test.make ~count:10 @@ -227,8 +243,8 @@ let machine_validation_tests = (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 _ -> + let* state, env = ValidationMachine.build ~invariant specs in + let* _ = ValidationMachine.run ~invariant scenario env state in return_unit)); QCheck2.Test.make ~count:10 @@ -238,8 +254,8 @@ let machine_validation_tests = (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 _ -> + let* state, env = ConcreteMachine.build ~invariant specs in + let* _ = ConcreteMachine.run ~invariant scenario env state in return_unit)); QCheck2.Test.make ~count:50_000 diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_bitset.ml b/src/proto_alpha/lib_protocol/test/pbt/test_bitset.ml index 641838f8cf9f..e3f5b22770b9 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_bitset.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_bitset.ml @@ -40,7 +40,7 @@ let gen_storage = let* bool_vector = list bool in match List.fold_left_i_e - (fun i storage v -> if v then add storage i else ok storage) + (fun i storage v -> if v then add storage i else Ok storage) empty bool_vector with 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 f41a81928f96..0a507e042358 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 @@ -35,10 +35,13 @@ open Lib_test.Qcheck2_helpers open QCheck2 open Protocol -let wrap m = m >|= Environment.wrap_tzresult +let wrap m = + let open Lwt_syntax in + let+ v = m in + Environment.wrap_tzresult v let new_ctxt () = - let ( let* ) m f = m >>=? f in + let open Lwt_result_syntax in let* block, _contract = Context.init1 () in let* incr = Incremental.begin_construction block in return @@ Incremental.alpha_ctxt incr @@ -79,10 +82,10 @@ let pp_int_map fmt map = Assert.pp_print_list (fun fmt (k, v) -> Format.fprintf fmt "(%d, %d)" k v) in Lwt_main.run - (let ( let* ) m f = m >>=? f in - let* ctxt = new_ctxt () in - let* kvs, _ = wrap @@ Lwt.return @@ CM.to_list ctxt map in - return kvs) + (let open Lwt_result_syntax in + let* ctxt = new_ctxt () in + let* kvs, _ = wrap @@ Lwt.return @@ CM.to_list ctxt map in + return kvs) |> Result.value_f ~default:(fun () -> assert false) |> Format.fprintf fmt "%a" pp 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 d6e766b8d51e..70b61fbfe932 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 @@ -45,58 +45,62 @@ let extract_qcheck_result = function let test_free_neutral (start, any_cost) = let open Alpha_context in extract_qcheck_result - ( Gas.consume start Gas.free >>? fun free_first -> - Gas.consume free_first any_cost >>? fun branch1 -> - Gas.consume start any_cost >>? fun cost_first -> - Gas.consume cost_first Gas.free >|? fun branch2 -> - let equal_consumption_from_start t1 t2 = - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:t1) - (Gas.consumed ~since:start ~until:t2)) - in - equal_consumption_from_start branch1 branch2 - && equal_consumption_from_start branch1 cost_first ) + (let open Result_syntax in + let* free_first = Gas.consume start Gas.free in + let* branch1 = Gas.consume free_first any_cost in + let* cost_first = Gas.consume start any_cost in + let+ branch2 = Gas.consume cost_first Gas.free in + let equal_consumption_from_start t1 t2 = + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:t1) + (Gas.consumed ~since:start ~until:t2)) + in + equal_consumption_from_start branch1 branch2 + && equal_consumption_from_start branch1 cost_first) (** Consuming [Gas.free] is equivalent to consuming nothing. *) let test_free_consumption start = let open Alpha_context in extract_qcheck_result - ( Gas.consume start Gas.free >|? fun after_empty_consumption -> - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:after_empty_consumption) - zero) ) + (let open Result_syntax in + let+ after_empty_consumption = Gas.consume start Gas.free in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:after_empty_consumption) + zero)) (** Consuming [cost1] then [cost2] is equivalent to consuming [Gas.(cost1 +@ cost2)]. *) let test_consume_commutes (start, cost1, cost2) = let open Alpha_context in extract_qcheck_result - ( Gas.consume start cost1 >>? fun after_cost1 -> - Gas.consume after_cost1 cost2 >>? fun branch1 -> - Gas.consume start Gas.(cost1 +@ cost2) >|? fun branch2 -> - Gas.Arith.( - qcheck_eq - ~pp - ~eq:equal - (Gas.consumed ~since:start ~until:branch1) - (Gas.consumed ~since:start ~until:branch2)) ) + (let open Result_syntax in + let* after_cost1 = Gas.consume start cost1 in + let* branch1 = Gas.consume after_cost1 cost2 in + let+ branch2 = Gas.consume start Gas.(cost1 +@ cost2) in + Gas.Arith.( + qcheck_eq + ~pp + ~eq:equal + (Gas.consumed ~since:start ~until:branch1) + (Gas.consumed ~since:start ~until:branch2))) (** Arbitrary context with a gas limit of 100_000_000. *) 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 -> - let state = Incremental.validation_state inc in - Alpha_context.Gas.set_limit - state.ctxt - Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000)) ) + (let open Lwt_result_syntax in + let* b, _contract = Context.init1 () in + let+ inc = Incremental.begin_construction b in + let state = Incremental.validation_state inc in + Alpha_context.Gas.set_limit + state.ctxt + Alpha_context.Gas.Arith.(fp (integral_of_int_exn 100_000_000))) |> function | Ok a -> a | Error _ -> assert false) 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 aba4549d2fb6..5aae649973c9 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 @@ -194,9 +194,10 @@ let assert_return x = assert_ok (Lwt_main.run x) let ctxt = assert_return - ( Context.init3 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> - return (Incremental.alpha_ctxt v) ) + (let open Lwt_result_syntax in + let* b, _cs = Context.init3 () in + let* v = Incremental.begin_construction b in + return (Incremental.alpha_ctxt v)) let unparse_comparable_ty ty = Micheline.strip_locations -- GitLab From 7c118ea5deba448823e394c02069470f9f668747 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 2 Sep 2022 15:46:54 +0200 Subject: [PATCH 2/4] Alpha/test/pbt: unit tests are unit tests This commit avoids wrapping unit tests in PBT tests in unit tests. --- .../test/pbt/test_carbonated_map.ml | 34 +++++++++++-------- 1 file changed, 20 insertions(+), 14 deletions(-) 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 0a507e042358..5c1a96425148 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 @@ -107,8 +107,8 @@ let int_map_pair_test name f = (fun (map1, map2) -> match f map1 map2 with Ok b -> b | Error _ -> false) let unit_test name f = - Test.make ~count:1 ~name (Gen.return ()) (fun () -> - match f () with Ok b -> b | _ -> false) + Alcotest.test_case name `Quick (fun () -> + match f () with Ok b -> assert b | _ -> assert false) let ( let* ) = Result.bind @@ -487,9 +487,8 @@ let test_size_remove_one = | None -> Ok (size' = size) | Some _ -> Ok (size' = size - 1) -let tests = +let qcheck_tests = [ - test_empty; test_size; test_to_list_of_list; test_empty_left_identity_for_merge; @@ -498,28 +497,35 @@ let tests = test_size_add_one; test_size_remove_one; test_merge_against_list; - test_merge_overlaps_left; - test_merge_overlaps_right; - test_merge_overlaps_add; test_merge_fail; - test_merge_map_keep_existing; - test_merge_map_replace_existing; test_find_non_existing; test_find_existing; + test_map; + test_fold; + test_fold_to_list; + test_map_fail; + ] + +let unit_tests = + [ + test_empty; test_update_add; test_update_replace; + test_merge_overlaps_left; + test_merge_overlaps_right; + test_merge_overlaps_add; test_update_merge; + test_merge_map_keep_existing; + test_merge_map_replace_existing; test_update_delete; - test_map; test_fold_empty; - test_fold; - test_fold_to_list; - test_map_fail; ] +let tests ~rand = qcheck_wrap ~rand qcheck_tests @ unit_tests + let () = (* Ensure deterministic results. *) let rand = Random.State.make [|0x1337533D; 71287309; 397060904|] in Alcotest.run "protocol > pbt > carbonated map" - [("Carbonated map", qcheck_wrap ~rand tests)] + [("Carbonated map", tests ~rand)] -- GitLab From 100f1699dc42ce41730f84739f9b1e5cceef3e52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 2 Sep 2022 15:54:25 +0200 Subject: [PATCH 3/4] Alpha/test/pbt: use syntax modules rather than define binding operator --- .../test/pbt/test_carbonated_map.ml | 27 +++++++++++++++++-- .../test/pbt/test_refutation_game.ml | 4 +-- 2 files changed, 27 insertions(+), 4 deletions(-) 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 5c1a96425148..a30939633626 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 @@ -110,18 +110,18 @@ let unit_test name f = Alcotest.test_case name `Quick (fun () -> match f () with Ok b -> assert b | _ -> assert false) -let ( let* ) = Result.bind - type Environment.Error_monad.error += Dummy_error let dummy_fail = Result.error (Environment.Error_monad.trace_of_error Dummy_error) let assert_map_contains ctxt map expected = + let open Result_syntax in let* kvs, _ctxt = CM.to_list ctxt map in Ok (List.sort compare kvs = List.sort compare expected) let assert_equal_map ctxt map expected = + let open Result_syntax in let* kvs, ctxt = CM.to_list ctxt expected in assert_map_contains ctxt map kvs @@ -131,6 +131,7 @@ let test_empty = (** Test adding a new element *) let test_update_add = + let open Result_syntax in unit_test "Update add" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -147,6 +148,7 @@ let test_update_add = (** Test replacing an existing element. *) let test_update_replace = + let open Result_syntax in unit_test "Update replace" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -163,6 +165,7 @@ let test_update_replace = (** Test merging when ignoring new overlapping keys. *) let test_merge_overlaps_left = + let open Result_syntax in unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -175,6 +178,7 @@ let test_merge_overlaps_left = (** Test merging when replacing the element of a new overlapping key. *) let test_merge_overlaps_right = + let open Result_syntax in unit_test "Merge overlap replace" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -187,6 +191,7 @@ let test_merge_overlaps_right = (** Test merging when combining elements of overlapping keys. *) let test_merge_overlaps_add = + let open Result_syntax in unit_test "Merge overlap by adding" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -199,6 +204,7 @@ let test_merge_overlaps_add = (** Test update with merging elements of new and existing keys by adding them. *) let test_update_merge = + let open Result_syntax in unit_test "Update with merge add" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -223,6 +229,7 @@ let test_update_merge = (** Test merging two maps when keeping the original value for overlapping keys. *) let test_merge_map_keep_existing = + let open Result_syntax in unit_test "Merge overlap keep existing" @@ fun () -> let ctxt = unsafe_new_context () in let* map1, ctxt = @@ -244,6 +251,7 @@ let test_merge_map_keep_existing = (** Test merging two maps when replacing the value for overlapping keys. *) let test_merge_map_replace_existing = + let open Result_syntax in unit_test "Merge overlap replace existing" @@ fun () -> let ctxt = unsafe_new_context () in let* map1, ctxt = @@ -269,6 +277,7 @@ let test_merge_map_replace_existing = (** Test deleting existing and non-existing keys. *) let test_update_delete = + let open Result_syntax in unit_test "Update delete" @@ fun () -> let ctxt = unsafe_new_context () in let* map, ctxt = @@ -286,6 +295,7 @@ let test_update_delete = (** Test that merging [empty] with a map returns the same map. *) let test_empty_left_identity_for_merge = + let open Result_syntax in int_map_test "Empty map is left identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in let* map', ctxt = @@ -295,6 +305,7 @@ let test_empty_left_identity_for_merge = (** Test that merging a map with [empty] returns the same map. *) let test_empty_right_identity_for_merge = + let open Result_syntax in int_map_test "Empty map is right identity for merge" @@ fun map -> let ctxt = unsafe_new_context () in let* map', ctxt = @@ -304,6 +315,7 @@ let test_empty_right_identity_for_merge = (** Test that [size] returns the number of key value pairs of a map. *) let test_size = + let open Result_syntax in int_map_test "Size returns the number of elements" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, _ = CM.to_list ctxt map in @@ -311,6 +323,7 @@ let test_size = (** Test that all keys of a map are found. *) let test_find_existing = + let open Result_syntax in int_map_test "Find all elements" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, _ = CM.to_list ctxt map in @@ -326,6 +339,7 @@ let test_find_existing = (** Test that find returns [None] for non-existing keys. *) let test_find_non_existing = + let open Result_syntax in int_map_test "Should not find non-existing" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, _ = CM.to_list ctxt map in @@ -337,6 +351,7 @@ let test_find_non_existing = (** Test that [to_list] followed by [of_list] returns the same map. *) let test_to_list_of_list = + let open Result_syntax in int_map_test "To-list/of-list roundtrip" @@ fun map -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in @@ -347,6 +362,7 @@ let test_to_list_of_list = (** Test that merging two maps is equivalent to merging the concatenated key-value lists of both maps. *) let test_merge_against_list = + let open Result_syntax in int_map_pair_test "Merge compared with list operation" @@ fun map1 map2 -> let ctxt = unsafe_new_context () in let merge_overlap ctxt x y = Ok (x + y, ctxt) in @@ -358,6 +374,7 @@ let test_merge_against_list = (** Test that merging a map with itself does not alter its size. *) let test_size_merge_self = + let open Result_syntax in int_map_test "Size should not change when map is merging with itself" @@ fun map -> let ctxt = unsafe_new_context () in @@ -385,6 +402,7 @@ let test_merge_fail = (** Test that adding one key-value pair to a map increases its size by one iff the key already exists. *) let test_size_add_one = + let open Result_syntax in int_map_test "Add a new element increases size by one" @@ fun map -> let ctxt = unsafe_new_context () in let key = 42 in @@ -417,6 +435,7 @@ let test_size_add_one = [map] --- to_list --> [list] *) let test_map = + let open Result_syntax in int_map_test "Test that map commutes with mapping over list" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, ctxt = CM.to_list ctxt map in @@ -427,6 +446,7 @@ let test_map = (** Test that folding over an empty map does not invoke the accumulator function. *) let test_fold_empty = + let open Result_syntax in unit_test "Fold empty" @@ fun () -> let ctxt = unsafe_new_context () in let* x, _ = CM.fold ctxt (fun _ctxt _acc _k _v -> dummy_fail) 0 CM.empty in @@ -442,6 +462,7 @@ let test_fold_empty = res <----- id -----> res *) let test_fold = + let open Result_syntax in int_map_test "Test that fold commutes with folding over a list" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, ctxt = CM.to_list ctxt map in @@ -454,6 +475,7 @@ let test_fold = (** Test that all key-value pairs can be collected by a fold. And that the order is the same as for [to_list]. *) let test_fold_to_list = + let open Result_syntax in int_map_test "Test that fold collecting the elements agrees with to-list" @@ fun map -> let ctxt = unsafe_new_context () in @@ -475,6 +497,7 @@ let test_map_fail = (** Test that removing an existing key from a map decreases its size by one. *) let test_size_remove_one = + let open Result_syntax in int_map_test "Remove new element decreases size by one" @@ fun map -> let ctxt = unsafe_new_context () in let* kvs, ctxt = CM.to_list ctxt map in 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 ef03298bcd9c..795bc63b1510 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 @@ -1293,8 +1293,8 @@ let build_proof ~player_client start_tick (game : Game.t) = let open Lwt_result_syntax in let inbox_context, messages_tree, history, inbox = player_client.inbox in let* history, history_proof = - Store_inbox.form_history_proof inbox_context history inbox messages_tree - >|= Environment.wrap_tzresult + Lwt.map Environment.wrap_tzresult + @@ Store_inbox.form_history_proof inbox_context history inbox messages_tree in (* We start a game on a commitment that starts at [Tick.initial], the fuel is necessarily [start_tick]. *) -- GitLab From 1a3ca1ef230d504393b3e59d3b8282d441c0e051 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Fri, 2 Sep 2022 15:58:01 +0200 Subject: [PATCH 4/4] Proto012/tests/pbt: reduce `count` --- .../lib_protocol/test/pbt/liquidity_baking_pbt.ml | 8 ++++---- .../lib_protocol/test/pbt/test_gas_properties.ml | 6 +++--- .../lib_protocol/test/pbt/test_sampler.ml | 4 ++-- .../lib_protocol/test/pbt/test_script_comparison.ml | 11 +++-------- 4 files changed, 12 insertions(+), 17 deletions(-) diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml index fb854096a0b5..559b570e77b6 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/liquidity_baking_pbt.ml @@ -240,7 +240,7 @@ let machine_validation_tests = ConcreteMachine.run ~invariant scenario env state >>=? fun _ -> return_unit)); QCheck.Test.make - ~count:100_000 + ~count:100 ~name:"Positive pools" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> @@ -257,7 +257,7 @@ let machine_validation_tests = let economic_tests = [ QCheck.Test.make - ~count:100_000 + ~count:100 ~name:"No global gain" (Liquidity_baking_generator.arb_adversary_scenario 1_000_000 1_000_000 50) (fun (specs, attacker, scenario) -> @@ -267,7 +267,7 @@ let economic_tests = in true); QCheck.Test.make - ~count:100_000 + ~count:100 ~name:"Remove liquidities is consistent" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> @@ -277,7 +277,7 @@ let economic_tests = in true); QCheck.Test.make - ~count:100_000 + ~count:100 ~name:"Share price only increases" (Liquidity_baking_generator.arb_scenario 1_000_000 1_000_000 50) (fun (specs, scenario) -> diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_gas_properties.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_gas_properties.ml index e421800eafd2..62cb2b8a8253 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_gas_properties.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_gas_properties.ml @@ -121,17 +121,17 @@ let gas_cost_arb : Alpha_context.Gas.cost QCheck.arbitrary = let tests = [ QCheck.Test.make - ~count:1000 + ~count:100 ~name:"Consuming commutes" QCheck.(triple context_arb gas_cost_arb gas_cost_arb) test_consume_commutes; QCheck.Test.make - ~count:1000 + ~count:100 ~name:"Consuming [free] consumes nothing" context_arb test_free_consumption; QCheck.Test.make - ~count:1000 + ~count:100 ~name:"[free] is the neutral element of Gas addition" QCheck.(pair context_arb gas_cost_arb) test_free_neutral; diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_sampler.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_sampler.ml index dc40670fde78..0859e6a87094 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_sampler.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_sampler.ml @@ -250,14 +250,14 @@ let qcheck_wrap = qcheck_wrap ~rand:state let alias_float_test = QCheck.Test.make - ~count:100 + ~count:10 ~name:"alias_float" QCheck.(list_of_size (Gen.int_range 1 20) pos_float) Test_float.make let alias_z_test = QCheck.Test.make - ~count:100 + ~count:10 ~name:"alias_z" QCheck.( list_of_size diff --git a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml index bee814df0699..b48d04be822a 100644 --- a/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml +++ b/src/proto_012_Psithaca/lib_protocol/test/pbt/test_script_comparison.ml @@ -334,14 +334,9 @@ let test_transitivity = *) let test_pack_unpack = QCheck.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 - time data is sent from a contract to another and also each time storage - is saved at the end of a smart contract call and restored at the next - call of the same contract. Also, injectivity of packing (which is a - direct consequence of this) is an important property for big maps - (because the keys are packed and then hashed). *) + ~count:100 + (* Because this protocol is not in active development, we only test a + small number of cases *) ~name:"pack_unpack" comparable_data_arbitrary (fun (Ex_comparable_data (ty, x)) -> -- GitLab