diff --git a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml index 5a663eb848308059b5b6bdc33d21e996b30dda80..32043ee302b722a8a043b7da9582ab639ffbced5 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/contract_helpers.ml @@ -25,12 +25,12 @@ open Protocol open Alpha_context -open Error_monad_operators (** Initializes 2 addresses to do only operations plus one that will be used to bake. *) let init () = - Context.init3 ~consensus_threshold:0 () >|=? fun (b, (src0, src1, src2)) -> + let open Lwt_result_syntax in + let+ b, (src0, src1, src2) = Context.init3 ~consensus_threshold:0 () in let baker = match src0 with Implicit v -> v | Originated _ -> assert false in @@ -50,16 +50,21 @@ let load_script ~storage file = (** Returns a block in which the contract is originated. *) let originate_contract_hash file storage src b baker = + let open Lwt_result_syntax in let script = load_script ~storage file in - Op.contract_origination_hash (B b) src ~fee:(Test_tez.of_int 10) ~script - >>=? fun (operation, dst) -> - Incremental.begin_construction ~policy:Block.(By_account baker) b - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >|=? fun b -> (dst, b) + let* operation, dst = + Op.contract_origination_hash (B b) src ~fee:(Test_tez.of_int 10) ~script + in + let* incr = + Incremental.begin_construction ~policy:Block.(By_account baker) b + in + let* incr = Incremental.add_operation incr operation in + let+ b = Incremental.finalize_block incr in + (dst, b) let originate_contract file storage src b baker = - originate_contract_hash file storage src b baker >|=? fun (dst, b) -> + let open Lwt_result_syntax in + let+ dst, b = originate_contract_hash file storage src b baker in (Contract.Originated dst, b) let fake_KT1 = @@ -98,48 +103,58 @@ let default_step_constants = let run_script ctx ?logger ?(step_constants = default_step_constants) ?(internal = false) contract ?(entrypoint = Entrypoint.default) ~storage ~parameter () = + let open Lwt_result_wrap_syntax in let contract_expr = Expr.from_string contract in let storage_expr = Expr.from_string storage in let parameter_expr = Expr.from_string parameter in let script = Script.{code = lazy_expr contract_expr; storage = lazy_expr storage_expr} in - Script_interpreter.execute - ctx - Readable - step_constants - ?logger - ~script - ~cached_script:None - ~entrypoint - ~parameter:parameter_expr - ~internal - >>=?? fun res -> return res + let*@ res = + Script_interpreter.execute + ctx + Readable + step_constants + ?logger + ~script + ~cached_script:None + ~entrypoint + ~parameter:parameter_expr + ~internal + in + return res let originate_contract_from_string_hash ~script ~storage ~source_contract ~baker block = + let open Lwt_result_syntax in let code = Expr.toplevel_from_string script in let storage = Expr.from_string storage in let script = Alpha_context.Script.{code = lazy_expr code; storage = lazy_expr storage} in - Op.contract_origination_hash - (B block) - source_contract - ~fee:(Test_tez.of_int 10) - ~script - >>=? fun (operation, dst) -> - Incremental.begin_construction ~policy:Block.(By_account baker) block - >>=? fun incr -> - Incremental.add_operation incr operation >>=? fun incr -> - Incremental.finalize_block incr >|=? fun b -> (dst, script, b) + let* operation, dst = + Op.contract_origination_hash + (B block) + source_contract + ~fee:(Test_tez.of_int 10) + ~script + in + let* incr = + Incremental.begin_construction ~policy:Block.(By_account baker) block + in + let* incr = Incremental.add_operation incr operation in + let+ b = Incremental.finalize_block incr in + (dst, script, b) let originate_contract_from_string ~script ~storage ~source_contract ~baker block = - originate_contract_from_string_hash - ~script - ~storage - ~source_contract - ~baker - block - >|=? fun (dst, script, b) -> (Contract.Originated dst, script, b) + let open Lwt_result_syntax in + let+ dst, script, b = + originate_contract_from_string_hash + ~script + ~storage + ~source_contract + ~baker + block + in + (Contract.Originated dst, script, b) diff --git a/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.ml b/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.ml deleted file mode 100644 index 9157c0b35a258b7697facdddec467cd30b0dd7e2..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.ml +++ /dev/null @@ -1,36 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -let ( >>=?? ) x y = - x >>= function - | Ok s -> y s - | Error err -> Lwt.return @@ Error (Environment.wrap_tztrace err) - -let ( >|=?? ) m f = m >>=?? fun x -> return (f x) - -let ( >>??= ) x y = - match x with - | Ok s -> y s - | Error err -> Lwt.return @@ Error (Environment.wrap_tztrace err) diff --git a/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.mli b/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.mli deleted file mode 100644 index bf0726c160b2bdaa85e04d9b2ffd8974b4110768..0000000000000000000000000000000000000000 --- a/src/proto_alpha/lib_protocol/test/helpers/error_monad_operators.mli +++ /dev/null @@ -1,39 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2022 Nomadic Labs *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -val ( >>=?? ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result Lwt.t -> - ('a -> ('b, error trace) result Lwt.t) -> - ('b, error trace) result Lwt.t - -val ( >|=?? ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result Lwt.t -> - ('a -> 'b) -> - ('b, error trace) result Lwt.t - -val ( >>??= ) : - ('a, Environment.Error_monad.error Environment.Error_monad.trace) result -> - ('a -> ('b, error trace) result Lwt.t) -> - ('b, error trace) result Lwt.t diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml index 827b0acb21919a9aa99c49717a82644738fbca2d..5faf2ce4e7b3e41aa1ed9313f5114881f5d57e94 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_typechecking.ml @@ -34,9 +34,6 @@ open Protocol open Alpha_context open Micheline -open Error_monad_operators - -let wrap_error_lwt x = x >>= fun x -> Lwt.return @@ Environment.wrap_tzresult x let context_init_with_sc_rollup_enabled tup = Context.init_with_constants_gen @@ -66,6 +63,7 @@ let sc_originate block contract parameters_ty = (* Test for Script_ir_translator.parse_and_unparse_script_unaccounted on a script declaring views. *) let test_unparse_view () = + let open Lwt_result_wrap_syntax in let dummy_contract = "{parameter unit; storage unit; code { CAR; NIL operation; PAIR }; view \ \"v0\" unit unit { DROP; UNIT }; view \"v1\" nat nat {CAR}}" @@ -76,46 +74,51 @@ let test_unparse_view () = let script = Script.{code = lazy_expr contract_expr; storage = lazy_expr storage_expr} in - Context.init3 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> + let* b, _cs = Context.init3 () in + let* v = Incremental.begin_construction b in let ctx = Incremental.alpha_ctxt v in - Script_ir_translator.parse_and_unparse_script_unaccounted - ctx - ~legacy:true - ~allow_forged_in_storage:false - Readable - ~normalize_types:true - script - >>=?? fun (unparsed_script, _ctx) -> + let*@ unparsed_script, _ctx = + Script_ir_translator.parse_and_unparse_script_unaccounted + ctx + ~legacy:true + ~allow_forged_in_storage:false + Readable + ~normalize_types:true + script + in let aft = Data_encoding.force_bytes unparsed_script.code in Alcotest.(check bytes) "didn't match" bef aft |> return let test_context () = - Context.init3 ~consensus_threshold:0 () >>=? fun (b, _cs) -> - Incremental.begin_construction b >>=? fun v -> + let open Lwt_result_syntax in + let* b, _cs = Context.init3 ~consensus_threshold:0 () in + let* v = Incremental.begin_construction b in return (Incremental.alpha_ctxt v) let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = - Context.init_with_constants1 - { - Context.default_test_constants with - sc_rollup = - { - Context.default_test_constants.sc_rollup with - enable = sc_rollup_enable; - }; - } - >>=? fun (b, source) -> - Op.contract_origination_hash (B b) source ~script:Op.dummy_script - >>=? fun (operation, originated) -> - Block.bake ~operation b >>=? fun b -> - Incremental.begin_construction b >>=? fun v -> + let open Lwt_result_wrap_syntax in + let* b, source = + Context.init_with_constants1 + { + Context.default_test_constants with + sc_rollup = + { + Context.default_test_constants.sc_rollup with + enable = sc_rollup_enable; + }; + } + in + let* operation, originated = + Op.contract_origination_hash (B b) source ~script:Op.dummy_script + in + let* b = Block.bake ~operation b in + let* v = Incremental.begin_construction b in let ctxt = Incremental.alpha_ctxt v in - wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> + let*@ ctxt, id = Big_map.fresh ~temporary:false ctxt in let nat_ty = Script_typed_ir.nat_t in - Environment.wrap_tzresult @@ Gas_monad.run_pure ctxt - @@ Script_ir_unparser.unparse_ty ~loc:() nat_ty - >>?= fun (nat_ty_node, ctxt) -> + let*?@ nat_ty_node, ctxt = + Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() nat_ty + in let nat_ty_expr = Micheline.strip_locations nat_ty_node in let alloc = Big_map.{key_type = nat_ty_expr; value_type = nat_ty_expr} in let init = Lazy_storage.Alloc alloc in @@ -127,9 +130,10 @@ let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = (Update {init; updates = []}); ] in - wrap_error_lwt - @@ Contract.update_script_storage ctxt originated nat_ty_expr (Some diffs) - >>=? fun ctxt -> return (ctxt, id) + let*@ ctxt = + Contract.update_script_storage ctxt originated nat_ty_expr (Some diffs) + in + return (ctxt, id) let read_file filename = let ch = open_in filename in @@ -142,11 +146,15 @@ let path = project_root // Filename.dirname __FILE__ (** Check that the custom stack overflow exception is triggered when it should be. *) let test_typecheck_stack_overflow () = - test_context () >>=? fun ctxt -> + let open Lwt_result_syntax in + let* ctxt = test_context () in let storage = "Unit" in let parameter = "Unit" in let script = read_file (path // "contracts/big_interpreter_stack.tz") in - Contract_helpers.run_script ctxt script ~storage ~parameter () >>= function + let*! result = + Contract_helpers.run_script ctxt script ~storage ~parameter () + in + match result with | Ok _ -> Alcotest.fail "expected an error" | Error lst when List.mem @@ -154,20 +162,23 @@ let test_typecheck_stack_overflow () = (Environment.Ecoproto_error Script_tc_errors.Typechecking_too_many_recursive_calls) lst -> - return () + return_unit | Error errs -> Alcotest.failf "Unexpected error: %a" Error_monad.pp_print_trace errs (* NOTE: this test fails with an out-of-memory exception. *) let _test_unparse_stack_overflow () = - test_context () >>=? fun ctxt -> + let open Lwt_result_syntax in + let* ctxt = test_context () in (* Meme *) let enorme_et_seq n = let rec aux n acc = aux (n - 1) @@ Micheline.Seq (0, [acc]) in aux n (Micheline.Int (0, Z.zero)) in - Script_ir_translator.(unparse_code ctxt Readable (enorme_et_seq 10_001)) - >>= function + let*! result = + Script_ir_translator.(unparse_code ctxt Readable (enorme_et_seq 10_001)) + in + match result with | Ok _ -> Alcotest.fail "expected an error" | Error trace -> let trace_string = @@ -229,6 +240,7 @@ let test_parse_ty (type exp expc) ctxt node return ctxt let test_parse_comb_type () = + let open Lwt_result_wrap_syntax in let open Script in let open Script_typed_ir in let nat_prim = Prim (-1, T_nat, [], []) in @@ -240,70 +252,84 @@ let test_parse_comb_type () = let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - test_context () >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_nat_nat_ty) = pair_ty nat_ty nat_ty in + let* ctxt = test_context () in (* pair nat nat *) - test_parse_ty ctxt pair_nat_nat_prim pair_nat_nat_ty >>?= fun ctxt -> + let*? ctxt = test_parse_ty ctxt pair_nat_nat_prim pair_nat_nat_ty in (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_pair_nat_nat_nat_ty) = pair_ty pair_nat_nat_ty nat_ty in + let*? ctxt = + test_parse_ty + ctxt + (pair_prim2 pair_nat_nat_prim nat_prim) + pair_pair_nat_nat_nat_ty + in (* pair nat (pair nat nat) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 nat_prim pair_nat_nat_prim) - pair_nat_pair_nat_nat_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_pair_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in + let*? ctxt = + test_parse_ty + ctxt + (pair_prim2 nat_prim pair_nat_nat_prim) + pair_nat_pair_nat_nat_ty + in (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in + let*? ctxt = + test_parse_ty + ctxt + (pair_prim [nat_prim; nat_prim; nat_prim]) + pair_nat_nat_nat_ty + in (* pair (nat %a) nat *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_a_nat_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim) pair_nat_a_nat_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_a_nat_ty) = pair_t (-1) nat_ty nat_ty in + let*? ctxt = + test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim) pair_nat_a_nat_ty + in (* pair nat (nat %b) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_b_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_nat_b_ty) = pair_t (-1) nat_ty nat_ty in + let*? ctxt = + test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty + in (* pair (nat %a) (nat %b) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_a_nat_b_ty) -> - test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_a_nat_b_ty) = pair_t (-1) nat_ty nat_ty in + let*? ctxt = + test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty + in (* pair (nat %a) (nat %b) (nat %c) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_b_nat_c_ty) -> - pair_t (-1) nat_ty pair_nat_b_nat_c_ty - >>??= fun (Ty_ex_c pair_nat_a_nat_b_nat_c_ty) -> - test_parse_ty - ctxt - (pair_prim [nat_prim_a; nat_prim_b; nat_prim_c]) - pair_nat_a_nat_b_nat_c_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_nat_b_nat_c_ty) = pair_t (-1) nat_ty nat_ty in + let*?@ (Ty_ex_c pair_nat_a_nat_b_nat_c_ty) = + pair_t (-1) nat_ty pair_nat_b_nat_c_ty + in + let*? ctxt = + test_parse_ty + ctxt + (pair_prim [nat_prim_a; nat_prim_b; nat_prim_c]) + pair_nat_a_nat_b_nat_c_ty + in (* pair (nat %a) (pair %b nat nat) *) - pair_t (-1) nat_ty nat_ty >>??= fun (Ty_ex_c pair_b_nat_nat_ty) -> - pair_t (-1) nat_ty pair_b_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_a_pair_b_nat_nat_ty) -> - test_parse_ty - ctxt - (pair_prim2 nat_prim_a (Prim (-1, T_pair, [nat_prim; nat_prim], ["%b"]))) - pair_nat_a_pair_b_nat_nat_ty - >>?= fun (_ : context) -> return_unit + let*?@ (Ty_ex_c pair_b_nat_nat_ty) = pair_t (-1) nat_ty nat_ty in + let*?@ (Ty_ex_c pair_nat_a_pair_b_nat_nat_ty) = + pair_t (-1) nat_ty pair_b_nat_nat_ty + in + let*? (_ : context) = + test_parse_ty + ctxt + (pair_prim2 nat_prim_a (Prim (-1, T_pair, [nat_prim; nat_prim], ["%b"]))) + pair_nat_a_pair_b_nat_nat_ty + in + return_unit let test_unparse_ty loc ctxt expected ty = + let open Result_syntax in Environment.wrap_tzresult - ( Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() ty - >>? fun (actual, ctxt) -> - if actual = expected then ok ctxt - else Alcotest.failf "Unexpected error: %s" loc ) + (let* actual, ctxt = + Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() ty + in + if actual = expected then Ok ctxt + else Alcotest.failf "Unexpected error: %s" loc) let test_unparse_comb_type () = + let open Lwt_result_wrap_syntax in let open Script in let open Script_typed_ir in let nat_prim = Prim ((), T_nat, [], []) in @@ -312,40 +338,46 @@ let test_unparse_comb_type () = let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> - test_context () >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_nat_nat_ty) = pair_ty nat_ty nat_ty in + let* ctxt = test_context () in (* pair nat nat *) - test_unparse_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty - >>?= fun ctxt -> + let*? ctxt = test_unparse_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty in (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_unparse_ty - __LOC__ - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> + let*?@ (Ty_ex_c pair_pair_nat_nat_nat_ty) = pair_ty pair_nat_nat_ty nat_ty in + let*? ctxt = + test_unparse_ty + __LOC__ + ctxt + (pair_prim2 pair_nat_nat_prim nat_prim) + pair_pair_nat_nat_nat_ty + in (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_nat_nat_ty) -> - test_unparse_ty - __LOC__ - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun (_ : context) -> return_unit + let*?@ (Ty_ex_c pair_nat_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in + let*? (_ : context) = + test_unparse_ty + __LOC__ + ctxt + (pair_prim [nat_prim; nat_prim; nat_prim]) + pair_nat_nat_nat_ty + in + return_unit let test_unparse_comparable_ty loc ctxt expected ty = (* unparse_comparable_ty is not exported, the simplest way to call it is to call parse_ty on a set type *) + let open Result_syntax in let open Script_typed_ir in Environment.wrap_tzresult - ( set_t (-1) ty >>? fun set_ty_ty -> - Gas_monad.run_pure ctxt @@ Script_ir_unparser.unparse_ty ~loc:() set_ty_ty - >>? fun (actual, ctxt) -> - if actual = Prim ((), T_set, [expected], []) then ok ctxt - else Alcotest.failf "Unexpected error: %s" loc ) + (let* set_ty_ty = set_t (-1) ty in + let* actual, ctxt = + Gas_monad.run_pure ctxt + @@ Script_ir_unparser.unparse_ty ~loc:() set_ty_ty + in + if actual = Prim ((), T_set, [expected], []) then return ctxt + else Alcotest.failf "Unexpected error: %s" loc) let test_unparse_comb_comparable_type () = + let open Lwt_result_wrap_syntax in let open Script in let open Script_typed_ir in let nat_prim = Prim ((), T_nat, [], []) in @@ -354,64 +386,72 @@ let test_unparse_comb_comparable_type () = let pair_ty ty1 ty2 = comparable_pair_t (-1) ty1 ty2 in let pair_prim2 a b = pair_prim [a; b] in let pair_nat_nat_prim = pair_prim2 nat_prim nat_prim in - pair_ty nat_ty nat_ty >>??= fun pair_nat_nat_ty -> - test_context () >>=? fun ctxt -> + let*?@ pair_nat_nat_ty = pair_ty nat_ty nat_ty in + let* ctxt = test_context () in (* pair nat nat *) - test_unparse_comparable_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty - >>?= fun ctxt -> + let*? ctxt = + test_unparse_comparable_ty __LOC__ ctxt pair_nat_nat_prim pair_nat_nat_ty + in (* pair (pair nat nat) nat *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun pair_pair_nat_nat_nat_ty -> - test_unparse_comparable_ty - __LOC__ - ctxt - (pair_prim2 pair_nat_nat_prim nat_prim) - pair_pair_nat_nat_nat_ty - >>?= fun ctxt -> + let*?@ pair_pair_nat_nat_nat_ty = pair_ty pair_nat_nat_ty nat_ty in + let*? ctxt = + test_unparse_comparable_ty + __LOC__ + ctxt + (pair_prim2 pair_nat_nat_prim nat_prim) + pair_pair_nat_nat_nat_ty + in (* pair nat nat nat *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun pair_nat_nat_nat_ty -> - test_unparse_comparable_ty - __LOC__ - ctxt - (pair_prim [nat_prim; nat_prim; nat_prim]) - pair_nat_nat_nat_ty - >>?= fun (_ : context) -> return_unit + let*?@ pair_nat_nat_nat_ty = pair_ty nat_ty pair_nat_nat_ty in + let*? (_ : context) = + test_unparse_comparable_ty + __LOC__ + ctxt + (pair_prim [nat_prim; nat_prim; nat_prim]) + pair_nat_nat_nat_ty + in + return_unit let test_parse_data ?(equal = Stdlib.( = )) loc ctxt ty node expected = + let open Lwt_result_wrap_syntax in let elab_conf = Script_ir_translator_config.make ~legacy:false () in let allow_forged = true in - wrap_error_lwt - ( Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node - >>=? fun (actual, ctxt) -> - if equal actual expected then return ctxt - else Alcotest.failf "Unexpected error: %s" loc ) + let*@ actual, ctxt = + Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node + in + if equal actual expected then return ctxt + else Alcotest.failf "Unexpected error: %s" loc let test_parse_data_fails loc ctxt ty node = + let open Lwt_result_wrap_syntax in let elab_conf = Script_ir_translator_config.make ~legacy:false () in let allow_forged = false in - wrap_error_lwt - (Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node - >>= function - | Ok _ -> Alcotest.failf "Unexpected typechecking success: %s" loc - | Error trace -> - let trace_string = - Format.asprintf "%a" Environment.Error_monad.pp_trace trace - in - let expect_id = "michelson_v1.invalid_constant" in - let expect_descrfiption = - "A data expression was invalid for its expected type." - in - if - Astring.String.is_infix ~affix:expect_id trace_string - && Astring.String.is_infix ~affix:expect_descrfiption trace_string - then return_unit - else - Alcotest.failf - "Unexpected error (%s) at %s" - trace_string - __LOC__ - return_unit) + let*! result = + Script_ir_translator.parse_data ctxt ~elab_conf ~allow_forged ty node + in + match result with + | Ok _ -> Alcotest.failf "Unexpected typechecking success: %s" loc + | Error trace -> + let trace_string = + Format.asprintf "%a" Environment.Error_monad.pp_trace trace + in + let expect_id = "michelson_v1.invalid_constant" in + let expect_descrfiption = + "A data expression was invalid for its expected type." + in + if + Astring.String.is_infix ~affix:expect_id trace_string + && Astring.String.is_infix ~affix:expect_descrfiption trace_string + then return_unit + else + Alcotest.failf + "Unexpected error (%s) at %s" + trace_string + __LOC__ + return_unit let test_parse_comb_data () = + let open Lwt_result_wrap_syntax in let open Script in let open Script_typed_ir in let z = Script_int.zero_n in @@ -419,72 +459,80 @@ let test_parse_comb_data () = let nat_ty = nat_t in let pair_prim l = Prim (-1, D_Pair, l, []) in let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> + let*?@ (Ty_ex_c pair_nat_nat_ty) = pair_ty nat_ty nat_ty in let pair_prim2 a b = pair_prim [a; b] in let pair_z_z_prim = pair_prim2 z_prim z_prim in - list_t (-1) nat_ty >>??= fun list_nat_ty -> - big_map_t (-1) nat_ty nat_ty >>??= fun big_map_nat_nat_ty -> - test_context_with_nat_nat_big_map () >>=? fun (ctxt, big_map_id) -> + let*?@ list_nat_ty = list_t (-1) nat_ty in + let*?@ big_map_nat_nat_ty = big_map_t (-1) nat_ty nat_ty in + let* ctxt, big_map_id = test_context_with_nat_nat_big_map () in (* Pair 0 0 *) - test_parse_data __LOC__ ctxt pair_nat_nat_ty pair_z_z_prim (z, z) - >>=? fun ctxt -> + let* ctxt = + test_parse_data __LOC__ ctxt pair_nat_nat_ty pair_z_z_prim (z, z) + in (* {0; 0} *) - test_parse_data - __LOC__ - ctxt - pair_nat_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim])) - (z, z) - >>=? fun ctxt -> + let* ctxt = + test_parse_data + __LOC__ + ctxt + pair_nat_nat_ty + (Micheline.Seq (-1, [z_prim; z_prim])) + (z, z) + in (* Pair (Pair 0 0) 0 *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_parse_data - __LOC__ - ctxt - pair_pair_nat_nat_nat_ty - (pair_prim2 pair_z_z_prim z_prim) - ((z, z), z) - >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_pair_nat_nat_nat_ty) = pair_ty pair_nat_nat_ty nat_ty in + let* ctxt = + test_parse_data + __LOC__ + ctxt + pair_pair_nat_nat_nat_ty + (pair_prim2 pair_z_z_prim z_prim) + ((z, z), z) + in (* Pair 0 (Pair 0 0) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (pair_prim2 z_prim pair_z_z_prim) - (z, (z, z)) - >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_nat_pair_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in + let* ctxt = + test_parse_data + __LOC__ + ctxt + pair_nat_pair_nat_nat_ty + (pair_prim2 z_prim pair_z_z_prim) + (z, (z, z)) + in (* Pair 0 0 0 *) - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (pair_prim [z_prim; z_prim; z_prim]) - (z, (z, z)) - >>=? fun ctxt -> + let* ctxt = + test_parse_data + __LOC__ + ctxt + pair_nat_pair_nat_nat_ty + (pair_prim [z_prim; z_prim; z_prim]) + (z, (z, z)) + in (* {0; 0; 0} *) - test_parse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) - (z, (z, z)) - >>=? fun ctxt -> + let* ctxt = + test_parse_data + __LOC__ + ctxt + pair_nat_pair_nat_nat_ty + (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) + (z, (z, z)) + in (* Should fail: {0} against pair nat (list nat) *) - pair_ty nat_ty list_nat_ty >>??= fun (Ty_ex_c pair_nat_list_nat_ty) -> - test_parse_data_fails - __LOC__ - ctxt - pair_nat_list_nat_ty - (Micheline.Seq (-1, [z_prim])) - >>=? fun () -> + let*?@ (Ty_ex_c pair_nat_list_nat_ty) = pair_ty nat_ty list_nat_ty in + let* () = + test_parse_data_fails + __LOC__ + ctxt + pair_nat_list_nat_ty + (Micheline.Seq (-1, [z_prim])) + in (* Should fail: {0; 0; 0} against pair nat (list nat) *) - test_parse_data_fails - __LOC__ - ctxt - pair_nat_list_nat_ty - (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) - >>=? fun () -> + let* () = + test_parse_data_fails + __LOC__ + ctxt + pair_nat_list_nat_ty + (Micheline.Seq (-1, [z_prim; z_prim; z_prim])) + in (* check Pair 0 (Pair 0 {}) against pair nat (big_map nat nat) so that the following test fails for the good reason and not because the big map doesn't exist @@ -521,16 +569,18 @@ let test_parse_comb_data () = && Big_map_overlay.bindings big_map1.diff.map = Big_map_overlay.bindings big_map2.diff.map in - pair_ty nat_ty big_map_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_big_map_nat_nat_ty) -> - test_parse_data - ~equal - __LOC__ - ctxt - pair_nat_big_map_nat_nat_ty - (pair_prim2 z_prim (pair_prim2 id_prim (Seq (-1, [])))) - (Script_int.zero_n, expected_big_map) - >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_nat_big_map_nat_nat_ty) = + pair_ty nat_ty big_map_nat_nat_ty + in + let* ctxt = + test_parse_data + ~equal + __LOC__ + ctxt + pair_nat_big_map_nat_nat_ty + (pair_prim2 z_prim (pair_prim2 id_prim (Seq (-1, [])))) + (Script_int.zero_n, expected_big_map) + in (* Should fail: Pair 0 0 {} against pair nat (big_map nat nat) *) test_parse_data_fails __LOC__ @@ -539,67 +589,77 @@ let test_parse_comb_data () = (pair_prim [z_prim; id_prim; Seq (-1, [])]) let test_parse_address () = + let open Lwt_result_wrap_syntax in let open Script_typed_ir in - test_context_with_nat_nat_big_map ~sc_rollup_enable:true () - >>=? fun (ctxt, _big_map_id) -> + let* ctxt, _big_map_id = + test_context_with_nat_nat_big_map ~sc_rollup_enable:true () + in (* KT1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return (Contract.of_b58check "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x")) - >>=? fun kt1fake -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x%")) - {destination = Contract kt1fake; entrypoint = Entrypoint.default} - >>=? fun ctxt -> + let*?@ kt1fake = + Contract.of_b58check "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x" + in + let* ctxt = + test_parse_data + __LOC__ + ctxt + address_t + (String (-1, "KT1FAKEFAKEFAKEFAKEFAKEFAKEFAKGGSE2x%")) + {destination = Contract kt1fake; entrypoint = Entrypoint.default} + in (* tz1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return (Contract.of_b58check "tz1fakefakefakefakefakefakefakcphLA5")) - >>=? fun tz1fake -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "tz1fakefakefakefakefakefakefakcphLA5%")) - {destination = Contract tz1fake; entrypoint = Entrypoint.default} - >>=? fun ctxt -> + let*?@ tz1fake = + Contract.of_b58check "tz1fakefakefakefakefakefakefakcphLA5" + in + let* ctxt = + test_parse_data + __LOC__ + ctxt + address_t + (String (-1, "tz1fakefakefakefakefakefakefakcphLA5%")) + {destination = Contract tz1fake; entrypoint = Entrypoint.default} + in (* scr1% (empty entrypoint) *) - wrap_error_lwt - (Lwt.return - (Destination.of_b58check "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG")) - >>=? fun scr1 -> - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG")) - {destination = scr1; entrypoint = Entrypoint.default} - >>=? fun ctxt -> + let*?@ scr1 = + Destination.of_b58check "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG" + in + let* ctxt = + test_parse_data + __LOC__ + ctxt + address_t + (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG")) + {destination = scr1; entrypoint = Entrypoint.default} + in (* scr1% (default entrypoint) *) - test_parse_data - __LOC__ - ctxt - address_t - (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG%")) - {destination = scr1; entrypoint = Entrypoint.default} - >|=? fun (_ctxt : context) -> () + let+ (_ctxt : context) = + test_parse_data + __LOC__ + ctxt + address_t + (String (-1, "sr1JPVatbbPoGp4vb6VfQ1jzEPMrYFcKq6VG%")) + {destination = scr1; entrypoint = Entrypoint.default} + in + () let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = - wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x - >>=? fun (actual_readable, ctxt) -> - (if actual_readable = Micheline.strip_locations expected_readable then - return ctxt - else Alcotest.failf "Error in readable unparsing: %s" loc) - >>=? fun ctxt -> - Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x - >>=? fun (actual_optimized, ctxt) -> - if actual_optimized = Micheline.strip_locations expected_optimized then - return ctxt - else Alcotest.failf "Error in optimized unparsing: %s" loc ) + let open Lwt_result_wrap_syntax in + let*@ actual_readable, ctxt = + Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x + in + let*@ ctxt = + if actual_readable = Micheline.strip_locations expected_readable then + return ctxt + else Alcotest.failf "Error in readable unparsing: %s" loc + in + let*@ actual_optimized, ctxt = + Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x + in + if actual_optimized = Micheline.strip_locations expected_optimized then + return ctxt + else Alcotest.failf "Error in optimized unparsing: %s" loc let test_unparse_comb_data () = + let open Lwt_result_wrap_syntax in let open Script in let open Script_typed_ir in let z = Script_int.zero_n in @@ -607,50 +667,56 @@ let test_unparse_comb_data () = let nat_ty = nat_t in let pair_prim l = Prim (-1, D_Pair, l, []) in let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - pair_ty nat_ty nat_ty >>??= fun (Ty_ex_c pair_nat_nat_ty) -> + let*?@ (Ty_ex_c pair_nat_nat_ty) = pair_ty nat_ty nat_ty in let pair_prim2 a b = pair_prim [a; b] in let pair_z_z_prim = pair_prim2 z_prim z_prim in - test_context () >>=? fun ctxt -> + let* ctxt = test_context () in (* Pair 0 0 *) - test_unparse_data - __LOC__ - ctxt - pair_nat_nat_ty - (z, z) - ~expected_readable:pair_z_z_prim - ~expected_optimized:pair_z_z_prim - >>=? fun ctxt -> + let* ctxt = + test_unparse_data + __LOC__ + ctxt + pair_nat_nat_ty + (z, z) + ~expected_readable:pair_z_z_prim + ~expected_optimized:pair_z_z_prim + in (* Pair (Pair 0 0) 0 *) - pair_ty pair_nat_nat_ty nat_ty >>??= fun (Ty_ex_c pair_pair_nat_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_pair_nat_nat_nat_ty - ((z, z), z) - ~expected_readable:(pair_prim2 pair_z_z_prim z_prim) - ~expected_optimized:(pair_prim2 pair_z_z_prim z_prim) - >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_pair_nat_nat_nat_ty) = pair_ty pair_nat_nat_ty nat_ty in + let* ctxt = + test_unparse_data + __LOC__ + ctxt + pair_pair_nat_nat_nat_ty + ((z, z), z) + ~expected_readable:(pair_prim2 pair_z_z_prim z_prim) + ~expected_optimized:(pair_prim2 pair_z_z_prim z_prim) + in (* Readable: Pair 0 0 0; Optimized: Pair 0 (Pair 0 0) *) - pair_ty nat_ty pair_nat_nat_ty >>??= fun (Ty_ex_c pair_nat_pair_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_nat_pair_nat_nat_ty - (z, (z, z)) - ~expected_readable:(pair_prim [z_prim; z_prim; z_prim]) - ~expected_optimized:(pair_prim2 z_prim pair_z_z_prim) - >>=? fun ctxt -> + let*?@ (Ty_ex_c pair_nat_pair_nat_nat_ty) = pair_ty nat_ty pair_nat_nat_ty in + let* ctxt = + test_unparse_data + __LOC__ + ctxt + pair_nat_pair_nat_nat_ty + (z, (z, z)) + ~expected_readable:(pair_prim [z_prim; z_prim; z_prim]) + ~expected_optimized:(pair_prim2 z_prim pair_z_z_prim) + in (* Readable: Pair 0 0 0 0; Optimized: {0; 0; 0; 0} *) - pair_ty nat_ty pair_nat_pair_nat_nat_ty - >>??= fun (Ty_ex_c pair_nat_pair_nat_pair_nat_nat_ty) -> - test_unparse_data - __LOC__ - ctxt - pair_nat_pair_nat_pair_nat_nat_ty - (z, (z, (z, z))) - ~expected_readable:(pair_prim [z_prim; z_prim; z_prim; z_prim]) - ~expected_optimized:(Micheline.Seq (-1, [z_prim; z_prim; z_prim; z_prim])) - >>=? fun (_ : context) -> return_unit + let*?@ (Ty_ex_c pair_nat_pair_nat_pair_nat_nat_ty) = + pair_ty nat_ty pair_nat_pair_nat_nat_ty + in + let* (_ : context) = + test_unparse_data + __LOC__ + ctxt + pair_nat_pair_nat_pair_nat_nat_ty + (z, (z, (z, z))) + ~expected_readable:(pair_prim [z_prim; z_prim; z_prim; z_prim]) + ~expected_optimized:(Micheline.Seq (-1, [z_prim; z_prim; z_prim; z_prim])) + in + return_unit (* Generate all the possible syntaxes for pairs *) let gen_pairs left right = @@ -673,6 +739,7 @@ let rec gen_combs leaf arity = (* Checks the optimality of the Optimized Micheline representation for combs *) let test_optimal_comb () = + let open Lwt_result_wrap_syntax in let open Script_typed_ir in let leaf_ty = nat_t in let leaf_mich = Int ((), Z.zero) in @@ -684,47 +751,49 @@ let test_optimal_comb () = @@ Data_encoding.Binary.to_bytes_exn Script.expr_encoding canonical ) in let check_optimal_comb loc ctxt ty v arity = - wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v - >>=? fun (unparsed, ctxt) -> - let unparsed_canonical, unparsed_size = - size_of_micheline (Micheline.root unparsed) - in - List.iter_es (fun other_repr -> - let other_repr_canonical, other_repr_size = - size_of_micheline other_repr - in - if other_repr_size < unparsed_size then - Alcotest.failf - "At %s, for comb of arity %d, representation %a (size %d \ - bytes) is shorter than representation %a (size %d bytes) \ - returned by unparse_data in Optimized mode" - loc - arity - Michelson_v1_printer.print_expr - other_repr_canonical - other_repr_size - Michelson_v1_printer.print_expr - unparsed_canonical - unparsed_size - else return_unit) - @@ gen_combs leaf_mich arity - >>=? fun () -> return ctxt ) + let*@ unparsed, ctxt = + Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v + in + let unparsed_canonical, unparsed_size = + size_of_micheline (Micheline.root unparsed) + in + let*@ () = + List.iter_es (fun other_repr -> + let other_repr_canonical, other_repr_size = + size_of_micheline other_repr + in + if other_repr_size < unparsed_size then + Alcotest.failf + "At %s, for comb of arity %d, representation %a (size %d bytes) \ + is shorter than representation %a (size %d bytes) returned by \ + unparse_data in Optimized mode" + loc + arity + Michelson_v1_printer.print_expr + other_repr_canonical + other_repr_size + Michelson_v1_printer.print_expr + unparsed_canonical + unparsed_size + else return_unit) + @@ gen_combs leaf_mich arity + in + return ctxt in let pair_ty ty1 ty2 = pair_t (-1) ty1 ty2 in - test_context () >>=? fun ctxt -> - pair_ty leaf_ty leaf_ty >>??= fun (Ty_ex_c comb2_ty) -> + let* ctxt = test_context () in + let*?@ (Ty_ex_c comb2_ty) = pair_ty leaf_ty leaf_ty in let comb2_v = (leaf_v, leaf_v) in - check_optimal_comb __LOC__ ctxt comb2_ty comb2_v 2 >>=? fun ctxt -> - pair_ty leaf_ty comb2_ty >>??= fun (Ty_ex_c comb3_ty) -> + let* ctxt = check_optimal_comb __LOC__ ctxt comb2_ty comb2_v 2 in + let*?@ (Ty_ex_c comb3_ty) = pair_ty leaf_ty comb2_ty in let comb3_v = (leaf_v, comb2_v) in - check_optimal_comb __LOC__ ctxt comb3_ty comb3_v 3 >>=? fun ctxt -> - pair_ty leaf_ty comb3_ty >>??= fun (Ty_ex_c comb4_ty) -> + let* ctxt = check_optimal_comb __LOC__ ctxt comb3_ty comb3_v 3 in + let*?@ (Ty_ex_c comb4_ty) = pair_ty leaf_ty comb3_ty in let comb4_v = (leaf_v, comb3_v) in - check_optimal_comb __LOC__ ctxt comb4_ty comb4_v 4 >>=? fun ctxt -> - pair_ty leaf_ty comb4_ty >>??= fun (Ty_ex_c comb5_ty) -> + let* ctxt = check_optimal_comb __LOC__ ctxt comb4_ty comb4_v 4 in + let*?@ (Ty_ex_c comb5_ty) = pair_ty leaf_ty comb4_ty in let comb5_v = (leaf_v, comb4_v) in - check_optimal_comb __LOC__ ctxt comb5_ty comb5_v 5 >>=? fun (_ : context) -> + let* (_ : context) = check_optimal_comb __LOC__ ctxt comb5_ty comb5_v 5 in return_unit let gas_monad_run ctxt m = @@ -738,49 +807,57 @@ let gas_monad_run ctxt m = behind this restriction. *) let test_contract_not_packable () = + let open Lwt_result_syntax in let elab_conf = Script_ir_translator_config.make ~legacy:false () in let contract_unit = Prim (0, Script.T_contract, [Prim (0, T_unit, [], [])], []) in - test_context () >>=? fun ctxt -> + let* ctxt = test_context () in (* Test that [contract_unit] is parsable *) - (match - gas_monad_run ctxt - @@ Script_ir_translator.parse_any_ty ~legacy:false contract_unit - with - | Ok _ -> Lwt_result_syntax.return_unit - | Error _ -> Alcotest.failf "Could not parse (contract unit)") - >>=? fun () -> + let* () = + match + gas_monad_run ctxt + @@ Script_ir_translator.parse_any_ty ~legacy:false contract_unit + with + | Ok _ -> Lwt_result_syntax.return_unit + | Error _ -> Alcotest.failf "Could not parse (contract unit)" + in (* Test that [contract_unit] is not packable *) - (match - gas_monad_run ctxt - @@ Script_ir_translator.parse_packable_ty ~legacy:false contract_unit - with - | Ok _ -> - Alcotest.failf - "(contract unit) should not be packable, see \ - https://gitlab.com/tezos/tezos/-/issues/301" - | Error _ -> return_unit) - >>=? fun () -> + let* () = + match + gas_monad_run ctxt + @@ Script_ir_translator.parse_packable_ty ~legacy:false contract_unit + with + | Ok _ -> + Alcotest.failf + "(contract unit) should not be packable, see \ + https://gitlab.com/tezos/tezos/-/issues/301" + | Error _ -> return_unit + in (* Test that elaboration of the [UNPACK unit] instruction succeeds *) - (Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf - (Prim (0, I_UNPACK, [Prim (0, T_unit, [], [])], [])) - (Item_t (Script_typed_ir.bytes_t, Bot_t)) - >>= function - | Ok _ -> return_unit - | Error _ -> Alcotest.failf "Could not parse UNPACK unit") - >>=? fun () -> + let* () = + let*! result = + Script_ir_translator.parse_instr + Script_tc_context.data + ctxt + ~elab_conf + (Prim (0, I_UNPACK, [Prim (0, T_unit, [], [])], [])) + (Item_t (Script_typed_ir.bytes_t, Bot_t)) + in + match result with + | Ok _ -> return_unit + | Error _ -> Alcotest.failf "Could not parse UNPACK unit" + in (* Test that elaboration of the [UNPACK (contract unit)] instruction fails *) - Script_ir_translator.parse_instr - Script_tc_context.data - ctxt - ~elab_conf - (Prim (0, I_UNPACK, [contract_unit], [])) - (Item_t (Script_typed_ir.bytes_t, Bot_t)) - >>= function + let*! result = + Script_ir_translator.parse_instr + Script_tc_context.data + ctxt + ~elab_conf + (Prim (0, I_UNPACK, [contract_unit], [])) + (Item_t (Script_typed_ir.bytes_t, Bot_t)) + in + match result with | Ok _ -> Alcotest.failf "UNPACK (contract unit) should not be allowed, see \ @@ -789,16 +866,19 @@ let test_contract_not_packable () = (* This test function is used to checks forbidden operations in views. *) let test_forbidden_op_in_view op () = + let open Lwt_result_syntax in let prefix = path // "contracts/forbidden_op_in_view_" in let script = read_file (prefix ^ op ^ ".tz") in let contract_expr = Expr.from_string script in - test_context () >>=? fun ctxt -> - Script_ir_translator.typecheck_code - ~legacy:false - ~show_types:false - ctxt - contract_expr - >>= function + let* ctxt = test_context () in + let*! result = + Script_ir_translator.typecheck_code + ~legacy:false + ~show_types:false + ctxt + contract_expr + in + match result with | Ok _ -> Alcotest.failf "%s should not be allowed in views, see \ @@ -808,19 +888,18 @@ let test_forbidden_op_in_view op () = (** Test [parse_contract_data] for rollup with unit type. *) let test_parse_contract_data_for_unit_rollup () = - let open Lwt_result_syntax in + let open Lwt_result_wrap_syntax in let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in let* block, rollup = sc_originate block contract "unit" in let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in - let* _ctxt, typed_contract = - wrap_error_lwt - @@ Script_ir_translator.parse_contract_data - ctxt - (-1) - Script_typed_ir.unit_t - (Destination.Sc_rollup rollup) - ~entrypoint:Entrypoint.default + let*@ _ctxt, typed_contract = + Script_ir_translator.parse_contract_data + ctxt + (-1) + Script_typed_ir.unit_t + (Destination.Sc_rollup rollup) + ~entrypoint:Entrypoint.default in let (Ty_ex_c Script_typed_ir.Unit_t) = Script_typed_ir.Typed_contract.arg_ty typed_contract @@ -838,18 +917,18 @@ let test_parse_contract_data_for_unit_rollup () = let* () = Assert.equal_string ~loc:__LOC__ (Entrypoint.to_string entrypoint) "default" in - return () + return_unit (** Test that [parse_contract_data] for rollup with invalid type fails. *) let test_parse_contract_data_for_rollup_with_invalid_type () = - let open Lwt_result_syntax in + let open Lwt_result_wrap_syntax in let* block, (contract, _) = context_init_with_sc_rollup_enabled T2 in let* block, rollup = sc_originate block contract "string" in let* incr = Incremental.begin_construction block in let ctxt = Incremental.alpha_ctxt incr in let entrypoint = Entrypoint.of_string_strict_exn "add" in let*! res = - wrap_error_lwt + wrap @@ Script_ir_translator.parse_contract_data ctxt (-1) @@ -863,18 +942,19 @@ let test_parse_contract_data_for_rollup_with_invalid_type () = (( = ) (Script_tc_errors.No_such_entrypoint entrypoint)) let test_contract path ~ok ~ko () = + let open Lwt_result_syntax in let contract = path in let script = read_file contract in let contract_expr = Expr.from_string script in - test_context () >>=? fun ctxt -> - Script_ir_translator.typecheck_code - ~legacy:false - ~show_types:false - ctxt - contract_expr - >>= function - | Ok _ -> ok () - | Error t -> ko t + let* ctxt = test_context () in + let*! result = + Script_ir_translator.typecheck_code + ~legacy:false + ~show_types:false + ctxt + contract_expr + in + match result with Ok _ -> ok () | Error t -> ko t let test_contract_success path = test_contract path ~ok:return ~ko:(fun t -> diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml index 5cb44332947db7d88749411c3ed9e2b8d4254111..f26f70257cdfda12872bfd639207a277922768b8 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_zk_rollup.ml @@ -33,7 +33,6 @@ open Protocol open Alpha_context -open Error_monad_operators exception Zk_rollup_test_error of string @@ -315,21 +314,27 @@ let test_append_external_deposit () = of the ticket containing [contents] of type [ty], crafted by [ticketer] and owned by [zk_rollup]. *) let make_ticket_key ctxt ~ty ~contents ~ticketer zk_rollup = - (match ctxt with - | Context.B block -> Incremental.begin_construction block - | Context.I incr -> return incr) - >>=? fun incr -> + let open Lwt_result_wrap_syntax in + let* incr = + match ctxt with + | Context.B block -> Incremental.begin_construction block + | Context.I incr -> return incr + in let ctxt = Incremental.alpha_ctxt incr in - Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty ty - >>??= fun (res, ctxt) -> - res >>??= fun (Ex_comparable_ty contents_type) -> - Script_ir_translator.parse_comparable_data ctxt contents_type contents - >>=?? fun (contents, ctxt) -> - Ticket_balance_key.of_ex_token - ctxt - ~owner:(Zk_rollup zk_rollup) - (Ticket_token.Ex_token {ticketer; contents_type; contents}) - >|=?? fst + let*?@ res, ctxt = + Gas_monad.run ctxt @@ Script_ir_translator.parse_comparable_ty ty + in + let*?@ (Ex_comparable_ty contents_type) = res in + let*@ contents, ctxt = + Script_ir_translator.parse_comparable_data ctxt contents_type contents + in + let+@ ticket_key, _ = + Ticket_balance_key.of_ex_token + ctxt + ~owner:(Zk_rollup zk_rollup) + (Ticket_token.Ex_token {ticketer; contents_type; contents}) + in + ticket_key module Make_ticket (T : sig val ty_str : string @@ -436,10 +441,12 @@ struct (** Return an operation to originate a contract that will deposit [amount] tickets with l2 operation [op] on [zk_rollup] *) let init_deposit ~block ~amount ~zk_op ~zk_rollup ~account = - init_deposit_contract amount block account - >>=? fun (deposit_contract, _script, block) -> - deposit_op ~block ~zk_rollup ~zk_op ~account ~deposit_contract - >|=? fun op -> (block, op, deposit_contract) + let open Lwt_result_syntax in + let* deposit_contract, _script, block = + init_deposit_contract amount block account + in + let+ op = deposit_op ~block ~zk_rollup ~zk_op ~account ~deposit_contract in + (block, op, deposit_contract) end module Nat_ticket = Make_ticket (struct @@ -553,15 +560,16 @@ let test_append_errors () = return_unit let assert_ticket_balance ~loc incr token owner expected = + let open Lwt_result_wrap_syntax in let ctxt = Incremental.alpha_ctxt incr in - Ticket_balance_key.of_ex_token ctxt ~owner token >>=?? fun (key_hash, ctxt) -> - Ticket_balance.get_balance ctxt key_hash >>=?? fun (balance, _) -> + let*@ key_hash, ctxt = Ticket_balance_key.of_ex_token ctxt ~owner token in + let*@ balance, _ = Ticket_balance.get_balance ctxt key_hash in match (balance, expected) with | Some b, Some e -> Assert.equal_int ~loc (Z.to_int b) e | Some b, None -> failwith "%s: Expected no balance but got some %d" loc (Z.to_int b) | None, Some b -> failwith "%s: Expected balance %d but got none" loc b - | None, None -> return () + | None, None -> return_unit let test_invalid_deposit () = let open Lwt_result_syntax in