diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 2fbb2f6c48dde48f77302856c6b810e23eb6feed..45853341c76d78bc0ee3c51bfa4d7d6d0be3e245 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -579,8 +579,7 @@ module Ty_eq : Benchmark.S = struct Lwt.return (Gas_monad.run ctxt @@ Script_ir_translator.ty_eq - ~error_details:Informative - dummy_loc + ~error_details:(Informative dummy_loc) ty ty) >|= Environment.wrap_tzresult @@ -596,8 +595,7 @@ module Ty_eq : Benchmark.S = struct ignore (Gas_monad.run ctxt @@ Script_ir_translator.ty_eq - ~error_details:Informative - dummy_loc + ~error_details:(Informative dummy_loc) ty ty) in diff --git a/src/proto_alpha/lib_plugin/plugin.ml b/src/proto_alpha/lib_plugin/plugin.ml index 4954df124046e8a617cbd457cdbdc8f068c0db77..26b7b444f4c905c32aa270202c3ecef03d726a9c 100644 --- a/src/proto_alpha/lib_plugin/plugin.ml +++ b/src/proto_alpha/lib_plugin/plugin.ml @@ -2210,7 +2210,7 @@ module RPC = struct -> Gas_monad.run ctxt @@ Script_ir_translator.find_entrypoint - ~error_details:Informative + ~error_details:(Informative ()) arg_type entrypoints entrypoint diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index f60675624690c936492b3a4e4571f42bd2322570..1f177396e90dd94ed7f6136150f33301c1b60279 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -412,7 +412,7 @@ let[@coq_axiom_with_reason "gadt"] register () = -> Gas_monad.run ctxt @@ Script_ir_translator.find_entrypoint - ~error_details:Informative + ~error_details:(Informative ()) arg_type entrypoints entrypoint diff --git a/src/proto_alpha/lib_protocol/gas_monad.ml b/src/proto_alpha/lib_protocol/gas_monad.ml index 1ab7a614954578621416cbcf35184bb7f813e4ab..3aa7e3f3fce04c050f84cbc2e11b14ca1c6f0987 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.ml +++ b/src/proto_alpha/lib_protocol/gas_monad.ml @@ -83,17 +83,18 @@ let run ctxt m = | None -> error Gas.Operation_quota_exceeded) let record_trace_eval : - type error_trace. - error_details:error_trace Script_tc_errors.error_details -> - (unit -> error) -> + type error_trace error_context. + error_details:(error_context, error_trace) Script_tc_errors.error_details -> + (error_context -> error) -> ('a, error_trace) t -> ('a, error_trace) t = fun ~error_details -> match error_details with | Fast -> fun _f m -> m - | Informative -> + | Informative err_ctxt -> fun f m gas -> - m gas >>?? fun (x, gas) -> of_result (record_trace_eval f x) gas + m gas >>?? fun (x, gas) -> + of_result (record_trace_eval (fun () -> f err_ctxt) x) gas let fail e = of_result (Error e) [@@ocaml.inline always] diff --git a/src/proto_alpha/lib_protocol/gas_monad.mli b/src/proto_alpha/lib_protocol/gas_monad.mli index f5f125a1432a4aa84ac8c9b02b65fb7800366266..159499a0066e3f92c06474c06213a7ef160c197c 100644 --- a/src/proto_alpha/lib_protocol/gas_monad.mli +++ b/src/proto_alpha/lib_protocol/gas_monad.mli @@ -69,8 +69,8 @@ val run : when run, records trace levels using [f]. This function has no effect in the case of a gas-exhaustion error or if [error_details] is [Fast]. *) val record_trace_eval : - error_details:'error_trace Script_tc_errors.error_details -> - (unit -> error) -> + error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> + ('error_context -> error) -> ('a, 'error_trace) t -> ('a, 'error_trace) t diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index dbe35717b19c6d310c1cd9d7bb5497896ffb95b8..7165051cb6dd0137bdcbc3a141531281fccd6cd1 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -1082,14 +1082,13 @@ and step : type a s b t r f. (a, s, b, t, r, f) step_type = original_code_expr = _; }, ctxt ) -> - let loc = Micheline.location view.view_code in let io_ty = let open Gas_monad.Syntax in let* out_eq = - ty_eq ~error_details:Fast loc output_ty' output_ty + ty_eq ~error_details:Fast output_ty' output_ty in let+ in_eq = - ty_eq ~error_details:Fast loc input_ty input_ty' + ty_eq ~error_details:Fast input_ty input_ty' in (out_eq, in_eq) in @@ -1697,8 +1696,7 @@ let lift_execution_arg (type a ac) ctxt ~internal (entrypoint_ty : (a, ac) ty) Gas_monad.run ctxt (Script_ir_translator.ty_eq - ~error_details:Informative - location + ~error_details:(Informative location) entrypoint_ty parsed_arg_ty) >>?= fun (res, ctxt) -> @@ -1740,7 +1738,11 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal ctxt ) -> Gas_monad.run ctxt - (find_entrypoint ~error_details:Informative arg_type entrypoints entrypoint) + (find_entrypoint + ~error_details:(Informative ()) + arg_type + entrypoints + entrypoint) >>?= fun (r, ctxt) -> record_trace (Bad_contract_parameter step_constants.self) r >>?= fun (Ex_ty_cstr {ty = entrypoint_ty; construct; original_type_expr = _}) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 0e2d823144ef291c19cf92bf0af8205c19714ae9..e8ffdc968f54f15e23deb89d1de66b40087659f0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -682,7 +682,7 @@ let check_dupable_ty ctxt loc ty = let type_metadata_eq : type error_trace. - error_details:error_trace error_details -> + error_details:(_, error_trace) error_details -> 'a ty_metadata -> 'b ty_metadata -> (unit, error_trace) result = @@ -696,7 +696,7 @@ let default_ty_eq_error loc ty1 ty2 = let memo_size_eq : type error_trace. - error_details:error_trace error_details -> + error_details:(_, error_trace) error_details -> Sapling.Memo_size.t -> Sapling.Memo_size.t -> (unit, error_trace) result = @@ -706,7 +706,7 @@ let memo_size_eq : Error (match error_details with | Fast -> Inconsistent_types_fast - | Informative -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) + | Informative _ -> trace_of_error @@ Inconsistent_memo_sizes (ms1, ms2)) (* Check that two types are equal. @@ -715,18 +715,15 @@ let memo_size_eq : *) let rec ty_eq : type a ac b bc error_trace. - error_details:error_trace error_details -> - Script.location -> + error_details:(Script.location, error_trace) error_details -> (a, ac) ty -> (b, bc) ty -> (((a, ac) ty, (b, bc) ty) eq, error_trace) Gas_monad.t = - fun ~error_details loc ty1 ty2 -> + fun ~error_details ty1 ty2 -> let type_metadata_eq meta1 meta2 = Gas_monad.of_result (type_metadata_eq ~error_details meta1 meta2) - |> Gas_monad.record_trace_eval ~error_details (fun () -> - let ty1 = serialize_ty_for_error ty1 in - let ty2 = serialize_ty_for_error ty2 in - Inconsistent_types (loc, ty1, ty2)) + |> Gas_monad.record_trace_eval ~error_details (fun loc -> + default_ty_eq_error loc ty1 ty2) in let memo_size_eq ms1 ms2 = Gas_monad.of_result (memo_size_eq ~error_details ms1 ms2) @@ -738,7 +735,7 @@ let rec ty_eq : (((ta, tac) ty, (tb, tbc) ty) eq, error_trace) Gas_monad.t = fun ty1 ty2 -> help0 ty1 ty2 - |> Gas_monad.record_trace_eval ~error_details (fun () -> + |> Gas_monad.record_trace_eval ~error_details (fun loc -> default_ty_eq_error loc ty1 ty2) and help0 : type ta tac tb tbc. @@ -753,7 +750,8 @@ let rec ty_eq : @@ Error (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> trace_of_error @@ default_ty_eq_error loc ty1 ty2) + | Informative loc -> + trace_of_error @@ default_ty_eq_error loc ty1 ty2) in match (ty1, ty2) with | (Unit_t, Unit_t) -> return (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) @@ -797,23 +795,23 @@ let rec ty_eq : | (Map_t (tal, tar, meta1), Map_t (tbl, tbr, meta2)) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tar tbr in - let+ Eq = ty_eq ~error_details loc tal tbl in + let+ Eq = ty_eq ~error_details tal tbl in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | (Map_t _, _) -> not_equal () | (Big_map_t (tal, tar, meta1), Big_map_t (tbl, tbr, meta2)) -> let* () = type_metadata_eq meta1 meta2 in let* Eq = help tar tbr in - let+ Eq = ty_eq ~error_details loc tal tbl in + let+ Eq = ty_eq ~error_details tal tbl in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | (Big_map_t _, _) -> not_equal () | (Set_t (ea, meta1), Set_t (eb, meta2)) -> let* () = type_metadata_eq meta1 meta2 in - let+ Eq = ty_eq ~error_details loc ea eb in + let+ Eq = ty_eq ~error_details ea eb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | (Set_t _, _) -> not_equal () | (Ticket_t (ea, meta1), Ticket_t (eb, meta2)) -> let* () = type_metadata_eq meta1 meta2 in - let+ Eq = ty_eq ~error_details loc ea eb in + let+ Eq = ty_eq ~error_details ea eb in (Eq : ((ta, tac) ty, (tb, tbc) ty) eq) | (Ticket_t _, _) -> not_equal () | (Pair_t (tal, tar, meta1, cmp1), Pair_t (tbl, tbr, meta2, cmp2)) -> @@ -887,7 +885,7 @@ let rec stack_eq : match (stack1, stack2) with | (Bot_t, Bot_t) -> ok (Eq, ctxt) | (Item_t (ty1, rest1), Item_t (ty2, rest2)) -> - Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc ty1 ty2 + Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) ty1 ty2 |> record_trace (Bad_stack_item lvl) >>? fun (eq, ctxt) -> eq >>? fun Eq -> @@ -1794,9 +1792,9 @@ type 'a ex_ty_cstr = } -> 'a ex_ty_cstr -let find_entrypoint (type full fullc error_trace) - ~(error_details : error_trace error_details) (full : (full, fullc) ty) - (entrypoints : full entrypoints) entrypoint : +let find_entrypoint (type full fullc error_context error_trace) + ~(error_details : (error_context, error_trace) error_details) + (full : (full, fullc) ty) (entrypoints : full entrypoints) entrypoint : (full ex_ty_cstr, error_trace) Gas_monad.t = let open Gas_monad.Syntax in let rec find_entrypoint : @@ -1842,11 +1840,11 @@ let find_entrypoint (type full fullc error_trace) @@ Error (match error_details with | Fast -> (Inconsistent_types_fast : error_trace) - | Informative -> trace_of_error @@ No_such_entrypoint entrypoint) + | Informative _ -> trace_of_error @@ No_such_entrypoint entrypoint) let find_entrypoint_for_type (type full fullc exp expc error_trace) ~error_details ~(full : (full, fullc) ty) ~(expected : (exp, expc) ty) - entrypoints entrypoint loc : + entrypoints entrypoint : (Entrypoint.t * (exp, expc) ty, error_trace) Gas_monad.t = let open Gas_monad.Syntax in let* res = find_entrypoint ~error_details full entrypoints entrypoint in @@ -1856,14 +1854,14 @@ let find_entrypoint_for_type (type full fullc exp expc error_trace) | Some {name; original_type_expr = _} when Entrypoint.is_root name && Entrypoint.is_default entrypoint -> Gas_monad.bind_recover - (ty_eq ~error_details:Fast loc ty expected) + (ty_eq ~error_details:Fast ty expected) (function | Ok Eq -> return (Entrypoint.default, (ty : (exp, expc) ty)) | Error Inconsistent_types_fast -> - let+ Eq = ty_eq ~error_details loc full expected in + let+ Eq = ty_eq ~error_details full expected in (Entrypoint.root, (full : (exp, expc) ty))) | _ -> - let+ Eq = ty_eq ~error_details loc ty expected in + let+ Eq = ty_eq ~error_details ty expected in (entrypoint, (ty : (exp, expc) ty))) let well_formed_entrypoints (type full fullc) (full : (full, fullc) ty) @@ -2688,8 +2686,9 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : (Gas_monad.run ctxt @@ let open Gas_monad.Syntax in - let* Eq = ty_eq ~error_details:Informative loc tk btk in - ty_eq ~error_details:Informative loc tv btv) + let error_details = Informative loc in + let* Eq = ty_eq ~error_details tk btk in + ty_eq ~error_details tv btv) >>? fun (eq, ctxt) -> eq >|? fun Eq -> (Some id, ctxt) ) else traced_fail (Unexpected_forged_value loc)) @@ -2736,7 +2735,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some transac_memo_size -> Lwt.return ( memo_size_eq - ~error_details:Informative + ~error_details:(Informative ()) memo_size transac_memo_size >|? fun () -> (transaction, ctxt) )) @@ -2755,7 +2754,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : | Some transac_memo_size -> Lwt.return ( memo_size_eq - ~error_details:Informative + ~error_details:(Informative ()) memo_size transac_memo_size >|? fun () -> (transaction, ctxt) )) @@ -2769,7 +2768,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : Lwt.return ( traced_no_lwt @@ memo_size_eq - ~error_details:Informative + ~error_details:(Informative ()) memo_size state.Sapling.memo_size >|? fun () -> (state, ctxt) ) @@ -2847,7 +2846,7 @@ and parse_view : {input_ty; output_ty; kinstr; original_code_expr = view_code}, ctxt ) | Typed ({loc; aft; _} as descr) -> ( - let ill_type_view loc stack_ty () = + let ill_type_view stack_ty loc = let actual = serialize_stack_for_error ctxt stack_ty in let expected_stack = Item_t (output_ty, Bot_t) in let expected = serialize_stack_for_error ctxt expected_stack in @@ -2855,18 +2854,18 @@ and parse_view : in match aft with | Item_t (ty, Bot_t) -> + let error_details = Informative loc in Gas_monad.run ctxt - @@ Gas_monad.record_trace_eval - ~error_details:Informative - (ill_type_view loc aft : unit -> _) - @@ ty_eq ~error_details:Informative loc ty output_ty + @@ Gas_monad.record_trace_eval ~error_details (fun loc -> + ill_type_view aft loc) + @@ ty_eq ~error_details ty output_ty >>? fun (eq, ctxt) -> eq >|? fun Eq -> let {kinstr; _} = close_descr descr in ( Typed_view {input_ty; output_ty; kinstr; original_code_expr = view_code}, ctxt ) - | _ -> error (ill_type_view loc aft ())) + | _ -> error (ill_type_view aft loc)) and parse_views : type storage storagec. @@ -2908,15 +2907,16 @@ and[@coq_axiom_with_reason "gadt"] parse_returning : >>=? function | (Typed ({loc; aft = Item_t (ty, Bot_t) as stack_ty; _} as descr), ctxt) -> Lwt.return - ( Gas_monad.run ctxt - @@ Gas_monad.record_trace_eval ~error_details:Informative (fun () -> - let ret = serialize_ty_for_error ret in - let stack_ty = serialize_stack_for_error ctxt stack_ty in - Bad_return (loc, stack_ty, ret)) - @@ ty_eq ~error_details:Informative loc ty ret - >>? fun (eq, ctxt) -> - eq >|? fun Eq -> - ((Lam (close_descr descr, script_instr) : (arg, ret) lambda), ctxt) ) + (let error_details = Informative loc in + Gas_monad.run ctxt + @@ Gas_monad.record_trace_eval ~error_details (fun loc -> + let ret = serialize_ty_for_error ret in + let stack_ty = serialize_stack_for_error ctxt stack_ty in + Bad_return (loc, stack_ty, ret)) + @@ ty_eq ~error_details ty ret + >>? fun (eq, ctxt) -> + eq >|? fun Eq -> + ((Lam (close_descr descr, script_instr) : (arg, ret) lambda), ctxt)) | (Typed {loc; aft = stack_ty; _}, ctxt) -> let ret = serialize_ty_for_error ret in let stack_ty = serialize_stack_for_error ctxt stack_ty in @@ -2945,7 +2945,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Bad_stack (loc, name, m, stack_ty)) @@ record_trace (Bad_stack_item n) - ( Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc exp got + ( Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) exp got >>? fun (eq, ctxt) -> eq >|? fun Eq -> ((Eq : (a, b) eq), ctxt) ) in @@ -3719,7 +3719,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : Item_t ((Sapling_state_t state_memo_size as state_ty), rest) ) ) -> if legacy then memo_size_eq - ~error_details:Informative + ~error_details:(Informative ()) state_memo_size transaction_memo_size >>?= fun () -> @@ -3738,7 +3738,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : ( Sapling_transaction_t transaction_memo_size, Item_t ((Sapling_state_t state_memo_size as state_ty), rest) ) ) -> memo_size_eq - ~error_details:Informative + ~error_details:(Informative ()) state_memo_size transaction_memo_size >>?= fun () -> @@ -4344,7 +4344,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : check_var_annot loc annot >>?= fun () -> parse_any_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy cast_t >>?= fun (Ex_ty cast_t, ctxt) -> - Gas_monad.run ctxt @@ ty_eq ~error_details:Informative loc cast_t t + Gas_monad.run ctxt @@ ty_eq ~error_details:(Informative loc) cast_t t >>?= fun (eq, ctxt) -> eq >>?= fun Eq -> (* We can reuse [stack] because [a ty = b ty] means [a = b]. *) @@ -4482,12 +4482,13 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : in trace (Ill_typed_contract (canonical_code, [])) views_result >>=? fun (_typed_views, ctxt) -> - (Gas_monad.run ctxt - @@ - let open Gas_monad.Syntax in - let* Eq = ty_eq ~error_details:Informative loc arg arg_type_full in - let* Eq = ty_eq ~error_details:Informative loc ret ret_type_full in - ty_eq ~error_details:Informative loc storage_type ginit) + (let error_details = Informative loc in + Gas_monad.run ctxt + @@ + let open Gas_monad.Syntax in + let* Eq = ty_eq ~error_details arg arg_type_full in + let* Eq = ty_eq ~error_details ret ret_type_full in + ty_eq ~error_details storage_type ginit) >>?= fun (storage_eq, ctxt) -> storage_eq >>?= fun Eq -> let instr = @@ -4570,7 +4571,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : | Toplevel {param_type; entrypoints; storage_type = _} -> Gas_monad.run ctxt @@ find_entrypoint - ~error_details:Informative + ~error_details:(Informative ()) param_type entrypoints entrypoint @@ -4739,7 +4740,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : rest ) ) -> check_var_annot loc annot >>?= fun () -> Gas_monad.run ctxt - @@ ty_eq ~error_details:Informative loc contents_ty_a contents_ty_b + @@ ty_eq ~error_details:(Informative loc) contents_ty_a contents_ty_b >>?= fun (eq, ctxt) -> eq >>?= fun Eq -> option_t loc ty_a >>?= fun res_ty -> @@ -4972,7 +4973,7 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra (* An implicit account on the "default" entrypoint always exists and has type unit. *) Lwt.return ( Gas_monad.run ctxt - @@ ty_eq ~error_details:Informative loc arg unit_t + @@ ty_eq ~error_details:(Informative loc) arg unit_t >>? fun (eq, ctxt) -> eq >|? fun Eq -> let destination : Destination.t = Contract contract in @@ -5007,12 +5008,11 @@ and[@coq_axiom_with_reason "complex mutually recursive definition"] parse_contra (* we don't check targ size here because it's a legacy contract code *) Gas_monad.run ctxt @@ find_entrypoint_for_type - ~error_details:Informative + ~error_details:(Informative loc) ~full:targ ~expected:arg entrypoints entrypoint - loc >>? fun (entrypoint_arg, ctxt) -> entrypoint_arg >|? fun (entrypoint, arg_ty) -> let address = {destination; entrypoint} in @@ -5165,7 +5165,7 @@ let parse_contract_for_script : if Entrypoint.is_default entrypoint then (* An implicit account on the "default" entrypoint always exists and has type unit. *) Lwt.return - ( Gas_monad.run ctxt @@ ty_eq ~error_details:Fast loc arg unit_t + ( Gas_monad.run ctxt @@ ty_eq ~error_details:Fast arg unit_t >|? fun (eq, ctxt) -> match eq with | Ok Eq -> @@ -5218,7 +5218,6 @@ let parse_contract_for_script : ~expected:arg entrypoints entrypoint - loc >|? fun (entrypoint_arg, ctxt) -> match entrypoint_arg with | Ok (entrypoint, arg_ty) -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index b903aa172ec32e4a43ff339c988836505833aed9..022b9beb4c0f1d45d9d58bab02651c761c743767 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -214,8 +214,7 @@ val big_map_get_and_update : Lwt.t val ty_eq : - error_details:'error_trace error_details -> - Script.location -> + error_details:(Script.location, 'error_trace) error_details -> ('a, 'ac) Script_typed_ir.ty -> ('b, 'bc) Script_typed_ir.ty -> ( (('a, 'ac) Script_typed_ir.ty, ('b, 'bc) Script_typed_ir.ty) eq, @@ -434,7 +433,7 @@ type 'a ex_ty_cstr = -> 'a ex_ty_cstr val find_entrypoint : - error_details:'error_trace error_details -> + error_details:(_, 'error_trace) error_details -> ('t, _) Script_typed_ir.ty -> 't Script_typed_ir.entrypoints -> Entrypoint.t -> diff --git a/src/proto_alpha/lib_protocol/script_tc_errors.ml b/src/proto_alpha/lib_protocol/script_tc_errors.ml index 15d25a3d74839ccc3be05542bb5871b7b213ab06..fa83dad68a1c4c58489cc43ba988ac16a2e34ab7 100644 --- a/src/proto_alpha/lib_protocol/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/script_tc_errors.ml @@ -206,6 +206,6 @@ the error will be ignored later. For example, when types are compared during the interpretation of the [CONTRACT] instruction any error will lead to returning [None] but the content of the error will be ignored. *) -type _ error_details = - | Informative : error trace error_details - | Fast : inconsistent_types_fast_error error_details +type (_, _) error_details = + | Informative : 'error_context -> ('error_context, error trace) error_details + | Fast : (_, inconsistent_types_fast_error) error_details diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index ee7e39bc3e5b7e00127cf18be4eefecdc82e4998..f298844ec1a9f74c802faf38f705d5ef1101026b 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -244,7 +244,7 @@ module type TYPE_SIZE = sig type 'a t val check_eq : - error_details:'error_trace Script_tc_errors.error_details -> + error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> 'a t -> 'b t -> (unit, 'error_trace) result @@ -288,7 +288,7 @@ module Type_size : TYPE_SIZE = struct let check_eq : type a b error_trace. - error_details:error_trace Script_tc_errors.error_details -> + error_details:(_, error_trace) Script_tc_errors.error_details -> a t -> b t -> (unit, error_trace) result = @@ -298,7 +298,7 @@ module Type_size : TYPE_SIZE = struct Error (match error_details with | Fast -> Inconsistent_types_fast - | Informative -> + | Informative _ -> trace_of_error @@ Script_tc_errors.Inconsistent_type_sizes (x, y)) let of_int loc size = diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 87f2c424bb26885ff02d2e53bf07da2d3a056db0..74817a1020f202a73942b78291bdd78d0e2680b8 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -177,7 +177,7 @@ module Type_size : sig type 'a t val check_eq : - error_details:'error_trace Script_tc_errors.error_details -> + error_details:('error_context, 'error_trace) Script_tc_errors.error_details -> 'a t -> 'b t -> (unit, 'error_trace) result 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 9919530c8444600c135f22f11e67bbdb62a917b2..5b3e4b34c6a10510ccae434d2449b6e5959d24b7 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 @@ -179,8 +179,7 @@ let test_parse_ty (type exp expc) ctxt node >>? fun (Script_ir_translator.Ex_ty actual, ctxt) -> Gas_monad.run ctxt @@ Script_ir_translator.ty_eq - ~error_details:Informative - (location node) + ~error_details:(Informative (location node)) actual expected >>? fun (eq, ctxt) -> diff --git a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml index 74893aa1a27a3985226c7c570d98a5f604fb0abf..373fb79f4dccf6e11b57a2734c894280d192acf1 100644 --- a/src/proto_alpha/lib_protocol/ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_operations_diff.ml @@ -168,8 +168,7 @@ let cast_transaction_parameter (type a ac b bc) ctxt location Gas_monad.run ctxt (Script_ir_translator.ty_eq - ~error_details:Informative - location + ~error_details:(Informative location) entry_arg_ty parameters_ty) >>?= fun (res, ctxt) -> @@ -201,7 +200,7 @@ let tickets_of_transaction ctxt ~destination ~entrypoint ~location Gas_monad.run ctxt (Script_ir_translator.find_entrypoint - ~error_details:Informative + ~error_details:(Informative ()) arg_type entrypoints entrypoint)