From e47aa4aa66c45272830a2e962be0e8e9491ada2b Mon Sep 17 00:00:00 2001 From: Marcin Pastudzki Date: Fri, 22 Jul 2022 09:37:06 +0200 Subject: [PATCH 1/4] Proto/Michelson: Move unparsing mode to Script_ir_unparser. --- .../translator_benchmarks.ml | 2 +- .../lib_client/client_proto_args.ml | 6 ++-- .../lib_client/client_proto_args.mli | 2 +- .../lib_client/client_proto_context.mli | 6 ++-- .../lib_client/client_proto_fa12.mli | 2 +- .../lib_client/client_proto_programs.ml | 2 +- .../lib_client/client_proto_programs.mli | 2 +- src/proto_alpha/lib_plugin/RPC.ml | 4 +-- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + src/proto_alpha/lib_protocol/dune | 4 +++ .../sc_rollup_management_protocol.ml | 2 +- .../lib_protocol/script_interpreter.mli | 4 +-- .../lib_protocol/script_ir_translator.ml | 3 +- .../lib_protocol/script_ir_translator.mli | 18 +++-------- .../lib_protocol/script_ir_unparser.ml | 31 ++++++++++++++++++ .../lib_protocol/script_ir_unparser.mli | 32 +++++++++++++++++++ .../michelson/test_ticket_accounting.ml | 8 ++--- .../test_ticket_lazy_storage_diff.ml | 2 +- .../michelson/test_ticket_operations_diff.ml | 6 ++-- .../michelson/test_ticket_scanner.ml | 2 +- .../michelson/test_typechecking.ml | 10 ++---- .../integration/operations/test_sc_rollup.ml | 2 +- .../test/regression/test_logging.ml | 2 +- .../lib_protocol/ticket_balance_key.ml | 6 ++-- 24 files changed, 107 insertions(+), 52 deletions(-) create mode 100644 src/proto_alpha/lib_protocol/script_ir_unparser.ml create mode 100644 src/proto_alpha/lib_protocol/script_ir_unparser.mli diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 9ec90ebfbf58..3dc5af3682bd 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -292,7 +292,7 @@ module Unparsing_data : Benchmark.S = struct Lwt_main.run (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized ty typed) with diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index 5a221a42371b..1915b09fee68 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -559,9 +559,9 @@ let unparsing_mode_parameter = return ["Readable"; "Optimized"; "Optimized_legacy"]) (fun _cctxt s -> match s with - | "Readable" -> return Script_ir_translator.Readable - | "Optimized" -> return Script_ir_translator.Optimized - | "Optimized_legacy" -> return Script_ir_translator.Optimized_legacy + | "Readable" -> return Script_ir_unparser.Readable + | "Optimized" -> return Script_ir_unparser.Optimized + | "Optimized_legacy" -> return Script_ir_unparser.Optimized_legacy | _ -> failwith "Unknown unparsing mode %s" s) let unparsing_mode_arg ~default = diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 180ec8580ccf..c10aaaa08278 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -150,7 +150,7 @@ val data_parameter : (Michelson_v1_parser.parsed, full) Clic.parameter val raw_level_parameter : (Raw_level.t, full) Clic.parameter val unparsing_mode_arg : - default:string -> (Script_ir_translator.unparsing_mode, full) Clic.arg + default:string -> (Script_ir_unparser.unparsing_mode, full) Clic.arg val enforce_indentation_flag : (bool, full) Clic.arg diff --git a/src/proto_alpha/lib_client/client_proto_context.mli b/src/proto_alpha/lib_client/client_proto_context.mli index 8dca7a77749e..2b5f73c969f4 100644 --- a/src/proto_alpha/lib_client/client_proto_context.mli +++ b/src/proto_alpha/lib_client/client_proto_context.mli @@ -38,7 +38,7 @@ val get_storage : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> Contract_hash.t -> Script.expr option tzresult Lwt.t @@ -79,7 +79,7 @@ val get_big_map_value : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> Big_map.Id.t -> Script_expr_hash.t -> Script.expr tzresult Lwt.t @@ -89,7 +89,7 @@ val get_script : #Protocol_client_context.rpc_context -> chain:Shell_services.chain -> block:Shell_services.block -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> normalize_types:bool -> Contract_hash.t -> Script.t option tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_fa12.mli b/src/proto_alpha/lib_client/client_proto_fa12.mli index 4817f9c68295..f3cafb56ef64 100644 --- a/src/proto_alpha/lib_client/client_proto_fa12.mli +++ b/src/proto_alpha/lib_client/client_proto_fa12.mli @@ -157,6 +157,6 @@ val run_view_action : action:action -> ?payer:Signature.public_key_hash -> ?gas:Gas.Arith.integral -> - unparsing_mode:Script_ir_translator.unparsing_mode -> + unparsing_mode:Script_ir_unparser.unparsing_mode -> unit -> Script.expr tzresult Lwt.t diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index 728e9ec1baaa..4412d16c001c 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -122,7 +122,7 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed = type simulation_params = { input : Michelson_v1_parser.parsed; - unparsing_mode : Script_ir_translator.unparsing_mode; + unparsing_mode : Script_ir_unparser.unparsing_mode; now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; diff --git a/src/proto_alpha/lib_client/client_proto_programs.mli b/src/proto_alpha/lib_client/client_proto_programs.mli index 40d5acac1b4f..383d2116b10b 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.mli +++ b/src/proto_alpha/lib_client/client_proto_programs.mli @@ -35,7 +35,7 @@ module Program : (* Parameters shared by both simulations (views, and contracts). *) type simulation_params = { input : Michelson_v1_parser.parsed; - unparsing_mode : Script_ir_translator.unparsing_mode; + unparsing_mode : Script_ir_unparser.unparsing_mode; now : Script_timestamp.t option; level : Script_int.n Script_int.num option; source : Contract.t option; diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 11a1fefef01b..7e6e5d822517 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -123,7 +123,7 @@ module Registration = struct end let unparsing_mode_encoding = - let open Script_ir_translator in + let open Script_ir_unparser in let open Data_encoding in union ~tag_size:`Uint8 @@ -468,7 +468,7 @@ module Scripts = struct end module type UNPARSING_MODE = sig - val unparsing_mode : Script_ir_translator.unparsing_mode + val unparsing_mode : Script_ir_unparser.unparsing_mode end module Traced_interpreter (Unparsing_mode : UNPARSING_MODE) = struct diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index f7729e81f1c9..71c7e7b36aac 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -188,6 +188,7 @@ "Apply_operation_result", "Apply_internal_results", "Apply_results", + "Script_ir_unparser", "Script_ir_translator", "Script_big_map", "Script_cache", diff --git a/src/proto_alpha/lib_protocol/dune b/src/proto_alpha/lib_protocol/dune index ec1225e2420f..07fb0c871a86 100644 --- a/src/proto_alpha/lib_protocol/dune +++ b/src/proto_alpha/lib_protocol/dune @@ -204,6 +204,7 @@ Apply_operation_result Apply_internal_results Apply_results + Script_ir_unparser Script_ir_translator Script_big_map Script_cache @@ -447,6 +448,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli @@ -670,6 +672,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli @@ -898,6 +901,7 @@ apply_operation_result.ml apply_operation_result.mli apply_internal_results.ml apply_internal_results.mli apply_results.ml apply_results.mli + script_ir_unparser.ml script_ir_unparser.mli script_ir_translator.ml script_ir_translator.mli script_big_map.ml script_big_map.mli script_cache.ml script_cache.mli diff --git a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml index 9237267ded70..8c689361ed9d 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_management_protocol.ml @@ -59,7 +59,7 @@ let make_internal_inbox_message ctxt ty ~payload ~sender ~source = let+ payload, ctxt = Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized ty payload in diff --git a/src/proto_alpha/lib_protocol/script_interpreter.mli b/src/proto_alpha/lib_protocol/script_interpreter.mli index bcca460b020f..bfee647aff66 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.mli +++ b/src/proto_alpha/lib_protocol/script_interpreter.mli @@ -96,7 +96,7 @@ val execute : ?logger:logger -> Alpha_context.t -> cached_script:Script_ir_translator.ex_script option -> - Script_ir_translator.unparsing_mode -> + Script_ir_unparser.unparsing_mode -> step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> @@ -114,7 +114,7 @@ val execute_with_typed_parameter : ?logger:logger -> Alpha_context.context -> cached_script:Script_ir_translator.ex_script option -> - Script_ir_translator.unparsing_mode -> + Script_ir_unparser.unparsing_mode -> step_constants -> script:Script.t -> entrypoint:Entrypoint.t -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index c224c3471340..4a2a3efd5d84 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -32,6 +32,7 @@ open Script open Script_tc_errors open Script_ir_annot open Script_typed_ir +open Script_ir_unparser module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing module Tc_context = Script_tc_context @@ -90,8 +91,6 @@ let compose_descr : type tc_context = Tc_context.t -type unparsing_mode = Optimized | Readable | Optimized_legacy - type type_logger = Script.location -> stack_ty_before:Script.expr list -> diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index cd0e7a8e8bdd..eb46a5d09a9b 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -158,14 +158,6 @@ type ('a, 's) judgement = val close_descr : ('a, 'b, 'c, 'd) descr -> ('a, 'b, 'c, 'd) Script_typed_ir.kdescr -(** Flag that drives unparsing of typed values to nodes. - - [Optimized_legacy] must be kept backward-compatible in order to compute - valid hashes (of big map keys). - - [Optimized] may be used as long as the result can be read by parse_data. - - [Readable] produces with [string] values instead of [bytes] when feasible. -*) -type unparsing_mode = Optimized | Readable | Optimized_legacy - (* ---- Lists, Sets and Maps ----------------------------------------------- *) (** {2 High-level Michelson Data Types} *) @@ -204,7 +196,7 @@ val parse_data : (* Unparsing an IR-typed data back into a Micheline node data *) val unparse_data : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> ('a, _) Script_typed_ir.ty -> 'a -> (Script.node * context) tzresult Lwt.t @@ -212,14 +204,14 @@ val unparse_data : val unparse_comparable_data : loc:'loc -> context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> 'a Script_typed_ir.comparable_ty -> 'a -> ('loc Script.michelson_node * context) tzresult Lwt.t val unparse_code : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> Script.node -> (Script.node * context) tzresult Lwt.t @@ -363,7 +355,7 @@ val parse_and_unparse_script_unaccounted : context -> legacy:bool -> allow_forged_in_storage:bool -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> normalize_types:bool -> Script.t -> (Script.t * context) tzresult Lwt.t @@ -459,7 +451,7 @@ val list_of_big_map_ids : lazy_storage_ids -> Big_map.Id.t list *) val extract_lazy_storage_diff : context -> - unparsing_mode -> + Script_ir_unparser.unparsing_mode -> temporary:bool -> to_duplicate:lazy_storage_ids -> to_update:lazy_storage_ids -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml new file mode 100644 index 000000000000..4e3bd2b643ee --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -0,0 +1,31 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(* open Alpha_context *) +(* open Micheline *) +(* open Script_typed_ir *) +(* module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing *) + +type unparsing_mode = Optimized | Readable | Optimized_legacy diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli new file mode 100644 index 000000000000..b2b71e1fb47b --- /dev/null +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -0,0 +1,32 @@ +(*****************************************************************************) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** Flag that drives unparsing of typed values to nodes. + - [Optimized_legacy] must be kept backward-compatible in order to compute + valid hashes (of big map keys). + - [Optimized] may be used as long as the result can be read by {!Script_translator.parse_data}. + - [Readable] produces with [string] values instead of [bytes] when feasible. +*) +type unparsing_mode = Optimized | Readable | Optimized_legacy diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 61068795b30a..896549268d10 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -60,7 +60,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = @@ Script_ir_translator.unparse_comparable_data ~loc:() ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in @@ -127,7 +127,7 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = (Script_ir_translator.unparse_comparable_data ~loc:Micheline.dummy_location ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable key_type key) in @@ -139,7 +139,7 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable value_type value) in @@ -382,7 +382,7 @@ let transfer_operation ctxt ~src ~destination ~arg_type ~arg = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable arg_type arg) in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index d8c857b49f42..9ff7038ac995 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -51,7 +51,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = @@ Script_ir_translator.unparse_comparable_data ~loc:() ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 2080c05f9014..1e5072f9571d 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -124,7 +124,7 @@ let string_of_ticket_token ctxt @@ Script_ir_translator.unparse_comparable_data ctxt ~loc:() - Script_ir_translator.Readable + Script_ir_unparser.Readable contents_type contents in @@ -310,7 +310,7 @@ let transfer_operation ~incr ~src ~destination ~parameters_ty ~parameters = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable parameters_ty parameters) in @@ -342,7 +342,7 @@ let transfer_operation_to_tx_rollup ~incr ~src ~parameters_ty ~parameters wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy parameters_ty parameters) in diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index 5a3ebfd37126..d003e9233053 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -76,7 +76,7 @@ let string_list_of_ex_tickets ctxt tickets = wrap @@ Script_ir_translator.unparse_data ctxt - Script_ir_translator.Readable + Script_ir_unparser.Readable cty contents in 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 4c7d8f96e845..c823b75f3707 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 @@ -578,12 +578,12 @@ let test_parse_address () = let test_unparse_data loc ctxt ty x ~expected_readable ~expected_optimized = wrap_error_lwt - ( Script_ir_translator.unparse_data ctxt Script_ir_translator.Readable ty x + ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Readable ty x >>=? fun (actual_readable, ctxt) -> (if actual_readable = expected_readable then return ctxt else Alcotest.failf "Error in readable unparsing: %s" loc) >>=? fun ctxt -> - Script_ir_translator.unparse_data ctxt Script_ir_translator.Optimized ty x + Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty x >>=? fun (actual_optimized, ctxt) -> if actual_optimized = expected_optimized then return ctxt else Alcotest.failf "Error in optimized unparsing: %s" loc ) @@ -674,11 +674,7 @@ let test_optimal_comb () = in let check_optimal_comb loc ctxt ty v arity = wrap_error_lwt - ( Script_ir_translator.unparse_data - ctxt - Script_ir_translator.Optimized - ty - v + ( Script_ir_translator.unparse_data ctxt Script_ir_unparser.Optimized ty v >>=? fun (unparsed, ctxt) -> let unparsed_canonical, unparsed_size = size_of_micheline unparsed in List.iter_es (fun other_repr -> diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 24a0e83814b2..bc14314945df 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -201,7 +201,7 @@ let verify_params ctxt ~parameters_ty ~parameters ~unparsed_parameters = wrap (Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized + Script_ir_unparser.Optimized parameters_ty parameters) in diff --git a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml index 37ed71abb690..b7a360e06849 100644 --- a/src/proto_alpha/lib_protocol/test/regression/test_logging.ml +++ b/src/proto_alpha/lib_protocol/test/regression/test_logging.ml @@ -37,7 +37,7 @@ open Alpha_context open Tezt module Traced_interpreter = Plugin.RPC.Scripts.Traced_interpreter (struct - let unparsing_mode = Script_ir_translator.Readable + let unparsing_mode = Script_ir_unparser.Readable end) type contract = {filename : string; storage : string} diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index 81a6b28a7021..cc882ce36317 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -46,7 +46,7 @@ let of_ex_token ctxt ~owner Script_ir_translator.unparse_comparable_data ~loc ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy contents_type contents >>=? fun (contents, ctxt) -> @@ -59,13 +59,13 @@ let of_ex_token ctxt ~owner in Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy Script_typed_ir.address_t ticketer_address >>=? fun (ticketer, ctxt) -> Script_ir_translator.unparse_data ctxt - Script_ir_translator.Optimized_legacy + Script_ir_unparser.Optimized_legacy Script_typed_ir.address_t owner_address >>=? fun (owner, ctxt) -> -- GitLab From f43dbfdcfb42bf497dbe8b9099da3c9572bde48e Mon Sep 17 00:00:00 2001 From: Marcin Pastudzki Date: Fri, 22 Jul 2022 13:08:10 +0200 Subject: [PATCH 2/4] Proto/Michelson: Move ex_ty type to Script_typed_ir. --- src/proto_alpha/lib_benchmark/michelson_samplers.ml | 6 +++--- src/proto_alpha/lib_benchmark/michelson_samplers.mli | 2 +- src/proto_alpha/lib_benchmark/type_helpers.mli | 5 ++--- .../script_typed_ir_size_benchmarks.ml | 4 ++-- src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml | 1 - .../lib_benchmarks_proto/translator_benchmarks.ml | 7 +++---- .../lib_benchmarks_proto/translator_workload.ml | 2 +- src/proto_alpha/lib_plugin/RPC.ml | 2 +- src/proto_alpha/lib_protocol/contract_services.ml | 4 +++- src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 -- src/proto_alpha/lib_protocol/script_ir_translator.mli | 3 +-- src/proto_alpha/lib_protocol/script_typed_ir.ml | 2 ++ src/proto_alpha/lib_protocol/script_typed_ir.mli | 2 ++ .../integration/michelson/test_script_typed_ir_size.ml | 1 - .../test/integration/michelson/test_ticket_scanner.ml | 2 +- .../test/integration/michelson/test_typechecking.ml | 2 +- src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml | 4 ++-- 17 files changed, 25 insertions(+), 26 deletions(-) diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.ml b/src/proto_alpha/lib_benchmark/michelson_samplers.ml index f1b643175a66..f36ab8c661e0 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.ml +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.ml @@ -244,7 +244,7 @@ module type S = sig module Michelson_base : Michelson_samplers_base.S module Random_type : sig - val m_type : size:int -> Script_ir_translator.ex_ty sampler + val m_type : size:int -> Script_typed_ir.ex_ty sampler val m_comparable_type : size:int -> Script_ir_translator.ex_comparable_ty sampler @@ -290,7 +290,7 @@ end) (* Random generation of Michelson types. *) module Random_type = struct let type_of_atomic_type_name (at_tn : atomic_type_name) : - Script_ir_translator.ex_ty = + Script_typed_ir.ex_ty = match at_tn with | `TString -> Ex_ty string_t | `TNat -> Ex_ty nat_t @@ -333,7 +333,7 @@ end) | `TKey -> Ex_comparable_ty key_t | `TChain_id -> Ex_comparable_ty chain_id_t - let rec m_type ~size : Script_ir_translator.ex_ty sampler = + let rec m_type ~size : Script_typed_ir.ex_ty sampler = let open Script_ir_translator in let open M in if size <= 0 then Stdlib.failwith "m_type: size <= 0" diff --git a/src/proto_alpha/lib_benchmark/michelson_samplers.mli b/src/proto_alpha/lib_benchmark/michelson_samplers.mli index c6730c7312ca..c333639b79a9 100644 --- a/src/proto_alpha/lib_benchmark/michelson_samplers.mli +++ b/src/proto_alpha/lib_benchmark/michelson_samplers.mli @@ -67,7 +67,7 @@ module type S = sig (** Samplers for random Michelson types. *) module Random_type : sig (** [m_type ~size] samples a type containing exactly [size] constructors. *) - val m_type : size:int -> Script_ir_translator.ex_ty sampler + val m_type : size:int -> Script_typed_ir.ex_ty sampler (** [m_comparable_type ~size] samples a comparable type containing exactly [size] constructors. *) diff --git a/src/proto_alpha/lib_benchmark/type_helpers.mli b/src/proto_alpha/lib_benchmark/type_helpers.mli index 1a041e001459..0cf310d3afcf 100644 --- a/src/proto_alpha/lib_benchmark/type_helpers.mli +++ b/src/proto_alpha/lib_benchmark/type_helpers.mli @@ -44,7 +44,7 @@ val michelson_type_list_to_ex_stack_ty : @raise Type_helpers_error if an error arises during parsing. *) val michelson_type_to_ex_ty : - Alpha_context.Script.expr -> Alpha_context.t -> Script_ir_translator.ex_ty + Alpha_context.Script.expr -> Alpha_context.t -> Script_typed_ir.ex_ty (** [stack_type_to_michelson_type_list] converts a Mikhailsky stack type to a stack represented as a list of Micheline expressions, each @@ -54,5 +54,4 @@ val michelson_type_to_ex_ty : val stack_type_to_michelson_type_list : Type.Stack.t -> Script_repr.expr list (** [base_type_to_ex_ty] converts a Mikhailsky type to a Michelson one. *) -val base_type_to_ex_ty : - Type.Base.t -> Alpha_context.t -> Script_ir_translator.ex_ty +val base_type_to_ex_ty : Type.Base.t -> Alpha_context.t -> Script_typed_ir.ex_ty diff --git a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml index a686c668cd40..a2c05ba2d8d9 100644 --- a/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/script_typed_ir_size_benchmarks.ml @@ -79,7 +79,7 @@ end = struct ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let ex_ty = Type_helpers.michelson_type_to_ex_ty michelson_type ctxt in match ex_ty with - | Script_ir_translator.Ex_ty ty -> ( + | Script_typed_ir.Ex_ty ty -> ( match Lwt_main.run (Script_ir_translator.parse_data @@ -144,7 +144,7 @@ module Type_size_benchmark : Tezos_benchmark.Benchmark.S = struct let models = [(model_name, size_based_model name)] - let type_size_benchmark (Script_ir_translator.Ex_ty ty) = + let type_size_benchmark (Script_typed_ir.Ex_ty ty) = let open Script_typed_ir_size.Internal_for_tests in let open Cache_memory_helpers in let size = Nodes.(to_int (fst (ty_size ty))) in diff --git a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml index 5a9813b17e33..6b1e614378b1 100644 --- a/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/ticket_benchmarks.ml @@ -183,7 +183,6 @@ let ticket_ty = This is a worst case type for [type_has_tickets], though nested unions, nested maps or nested lists would be just as bad. *) let rec dummy_type_generator ~rng_state size = - let open Script_ir_translator in let open Script_typed_ir in let ticket_or_int = if Base_samplers.uniform_bool rng_state then Ex_ty ticket_ty diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 3dc5af3682bd..65eac153dd53 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -206,7 +206,7 @@ module Typechecking_data : Benchmark.S = struct | Some workload -> workload in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> let closure () = match Lwt_main.run @@ -278,7 +278,7 @@ module Unparsing_data : Benchmark.S = struct | Some workload -> workload in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> Script_ir_translator.parse_data ctxt ~legacy:false @@ -570,7 +570,7 @@ module Ty_eq : Benchmark.S = struct let models = [("size_translator_model", size_model); ("codegen", codegen_model)] - let ty_eq_benchmark rng_state nodes (ty : Script_ir_translator.ex_ty) = + let ty_eq_benchmark rng_state nodes (ty : Script_typed_ir.ex_ty) = Lwt_main.run ( Execution_context.make ~rng_state >>=? fun (ctxt, _) -> let ctxt = Gas_helpers.set_limit ctxt in @@ -630,7 +630,6 @@ let () = Registration_helpers.register (module Ty_eq) an extra test is performed to determine if the comb type needs to be folded. *) let rec dummy_type_generator size = - let open Script_ir_translator in let open Script_typed_ir in if size <= 1 then Ex_ty unit_t else diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml index 065fd6007e71..0d7d92c73446 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_workload.ml @@ -110,7 +110,7 @@ let workload_to_sparse_vec (trace : t) = let data_typechecker_workload ctxt t_kind micheline_node ex_ty = let open Protocol in match ex_ty with - | Script_ir_translator.Ex_ty ty -> + | Script_typed_ir.Ex_ty ty -> let ctxt = Gas_helpers.set_limit ctxt in Lwt_main.run ( Script_ir_translator.parse_data diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 7e6e5d822517..303caeb4aac9 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1451,7 +1451,7 @@ module Scripts = struct (Micheline.root script) >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ; Registration.register0 ~chunked:true S.normalize_type (fun ctxt () typ -> - let open Script_ir_translator in + let open Script_typed_ir in let ctxt = Gas.set_unlimited ctxt in (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *) Script_ir_translator.parse_ty diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index f067f3b48e3b..8840d72768be 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -486,7 +486,9 @@ let register () = entrypoints in Entrypoint.Map.fold_e - (fun entry (Ex_ty ty, original_type_expr) (acc, ctxt) -> + (fun entry + (Script_typed_ir.Ex_ty ty, original_type_expr) + (acc, ctxt) -> (if normalize_types then unparse_ty ~loc:() ctxt ty >|? fun (ty_node, ctxt) -> (Micheline.strip_locations ty_node, ctxt) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 4a2a3efd5d84..401d2a7c77f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -943,8 +943,6 @@ let parse_memo_size (n : (location, _) Micheline.node) : type ex_comparable_ty = | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) ty -> ex_ty - type ex_parameter_ty_and_entrypoints_node = | Ex_parameter_ty_and_entrypoints_node : { arg_type : ('a, _) ty; diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index eb46a5d09a9b..90b10b7b91f8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -63,6 +63,7 @@ (** {1 Michelson Existential Witness types} *) open Alpha_context +open Script_typed_ir open Script_tc_errors type ('ta, 'tb) eq = Eq : ('same, 'same) eq @@ -70,8 +71,6 @@ type ('ta, 'tb) eq = Eq : ('same, 'same) eq type ex_comparable_ty = | Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> ex_comparable_ty -type ex_ty = Ex_ty : ('a, _) Script_typed_ir.ty -> ex_ty - type ex_parameter_ty_and_entrypoints = | Ex_parameter_ty_and_entrypoints : { arg_type : ('a, _) Script_typed_ir.ty; diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index e47943604c64..245dc02c3b80 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -1416,6 +1416,8 @@ and operation = { lazy_storage_diff : Lazy_storage.diffs option; } +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty + type ('arg, 'storage) script = | Script : { code : diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 0af068f38163..75191ba3e586 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -1565,6 +1565,8 @@ type ('arg, 'storage) script = } -> ('arg, 'storage) script +type ex_ty = Ex_ty : ('a, _) ty -> ex_ty + val manager_kind : 'kind internal_operation_contents -> 'kind Kind.manager val kinstr_location : (_, _, _, _) kinstr -> Script.location diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml index a9d66415bd8c..d9a9d6af2b26 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_script_typed_ir_size.ml @@ -34,7 +34,6 @@ open Protocol open Alpha_context -open Script_ir_translator open Script_typed_ir (* diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml index d003e9233053..6f843eb7b1da 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_scanner.ml @@ -127,7 +127,7 @@ let assert_equals_ex_tickets ctxt ~loc ex_tickets expected = let tickets_of_value ctxt ~include_lazy ~allow_zero_amount_tickets ~type_exp ~value_exp = - let Script_ir_translator.Ex_ty ty, ctxt = + let Script_typed_ir.Ex_ty ty, ctxt = let node = Micheline.root @@ Expr.from_string type_exp in Result.value_f ~default:(fun () -> Stdlib.failwith "Failed to parse") 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 c823b75f3707..013a4b0f380c 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 @@ -211,7 +211,7 @@ let test_parse_ty (type exp expc) ctxt node ~allow_contract ~allow_ticket node - >>? fun (Script_ir_translator.Ex_ty actual, ctxt) -> + >>? fun (Script_typed_ir.Ex_ty actual, ctxt) -> Gas_monad.run ctxt @@ Script_ir_translator.ty_eq ~error_details:(Informative (location node)) diff --git a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml index d2aaa66055fc..b76f582767fe 100644 --- a/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/ticket_lazy_storage_diff.ml @@ -174,7 +174,7 @@ let collect_token_diffs_of_big_map_updates ctxt big_map_id ~value_type updates We should have the non-serialized version of the value type. *) parse_value_type ctxt value_type - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> List.fold_left_es @@ -204,7 +204,7 @@ let collect_token_diffs_of_big_map ctxt ~get_token_and_amount big_map_id acc = type. It would be more efficient if the value preserved. *) parse_value_type ctxt value_ty - >>?= fun (Script_ir_translator.Ex_ty value_type, ctxt) -> + >>?= fun (Script_typed_ir.Ex_ty value_type, ctxt) -> Ticket_scanner.type_has_tickets ctxt value_type >>?= fun (has_tickets, ctxt) -> (* Iterate over big-map items. *) -- GitLab From 6b993fee8702ca418fa28a01edf3380670ab8bc9 Mon Sep 17 00:00:00 2001 From: Marcin Pastudzki Date: Fri, 22 Jul 2022 13:20:16 +0200 Subject: [PATCH 3/4] Proto/Michelson: Extract unparsing functions from Script_typed_ir. The few functions from Script_ir_unparsing that depend on Script_ir_translator are wrapped in a functor. --- .../translator_benchmarks.ml | 2 +- src/proto_alpha/lib_plugin/RPC.ml | 2 +- src/proto_alpha/lib_protocol/apply.ml | 2 +- .../lib_protocol/contract_services.ml | 6 +- .../lib_protocol/script_interpreter_defs.ml | 4 +- .../lib_protocol/script_ir_translator.ml | 678 +---------------- .../lib_protocol/script_ir_translator.mli | 25 +- .../lib_protocol/script_ir_unparser.ml | 710 +++++++++++++++++- .../lib_protocol/script_ir_unparser.mli | 180 +++++ .../michelson/test_ticket_accounting.ml | 11 +- .../test_ticket_lazy_storage_diff.ml | 2 +- .../michelson/test_ticket_operations_diff.ml | 2 +- .../michelson/test_typechecking.ml | 6 +- .../test/pbt/test_script_comparison.ml | 2 +- .../lib_protocol/ticket_balance_key.ml | 4 +- 15 files changed, 915 insertions(+), 721 deletions(-) diff --git a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml index 65eac153dd53..87b1186807e5 100644 --- a/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml +++ b/src/proto_alpha/lib_benchmarks_proto/translator_benchmarks.ml @@ -693,7 +693,7 @@ let parse_ty ctxt node = ~allow_ticket:true node -let unparse_ty ctxt ty = Script_ir_translator.unparse_ty ~loc:(-1) ctxt ty +let unparse_ty ctxt ty = Script_ir_unparser.unparse_ty ~loc:(-1) ctxt ty module Parse_type_benchmark : Benchmark.S = struct include Parse_type_shared diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 303caeb4aac9..e6de2ed315ef 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -556,7 +556,7 @@ module Scripts = struct >>?= fun (Ex_ty exp_ty, ctxt) -> trace_eval (fun () -> - let exp_ty = Script_ir_translator.serialize_ty_for_error exp_ty in + let exp_ty = Script_ir_unparser.serialize_ty_for_error exp_ty in Script_tc_errors.Ill_typed_data (None, data, exp_ty)) (let allow_forged = true diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index 7f9f086db701..02f02c46665a 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -931,7 +931,7 @@ let ex_ticket_size : fun ctxt (Ex_ticket (ty, ticket)) -> (* type *) Script_typed_ir.ticket_t Micheline.dummy_location ty >>?= fun ty -> - Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt ty + Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt ty >>?= fun (ty', ctxt) -> let ty_nodes, ty_size = Script_typed_ir_size.node_size ty' in let ty_size = Saturation_repr.to_int ty_size in diff --git a/src/proto_alpha/lib_protocol/contract_services.ml b/src/proto_alpha/lib_protocol/contract_services.ml index 8840d72768be..8804e19b0edc 100644 --- a/src/proto_alpha/lib_protocol/contract_services.ml +++ b/src/proto_alpha/lib_protocol/contract_services.ml @@ -451,7 +451,8 @@ let register () = r |> function | Ok (Ex_ty_cstr {ty; original_type_expr; _}) -> if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, _ctxt) -> + Script_ir_unparser.unparse_ty ~loc:() ctxt ty + >|? fun (ty_node, _ctxt) -> Some (Micheline.strip_locations ty_node) else ok (Some (Micheline.strip_locations original_type_expr)) @@ -490,7 +491,8 @@ let register () = (Script_typed_ir.Ex_ty ty, original_type_expr) (acc, ctxt) -> (if normalize_types then - unparse_ty ~loc:() ctxt ty >|? fun (ty_node, ctxt) -> + Script_ir_unparser.unparse_ty ~loc:() ctxt ty + >|? fun (ty_node, ctxt) -> (Micheline.strip_locations ty_node, ctxt) else ok (Micheline.strip_locations original_type_expr, ctxt)) diff --git a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml index 67f8fa5791c6..eb09e705a2cf 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter_defs.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter_defs.ml @@ -433,7 +433,7 @@ let apply ctxt gas capture_ty capture lam = let ctxt = update_context gas ctxt in unparse_data ctxt Optimized capture_ty capture >>=? fun (const_expr, ctxt) -> let loc = Micheline.dummy_location in - unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> + Script_ir_unparser.unparse_ty ~loc ctxt capture_ty >>?= fun (ty_expr, ctxt) -> match full_arg_ty with | Pair_t (capture_ty, arg_ty, _, _) -> let arg_stack_ty = Item_t (arg_ty, Bot_t) in @@ -483,7 +483,7 @@ let make_transaction_to_tx_rollup (type t) ctxt ~destination ~amount unparse_data ctxt Optimized parameters_ty parameters >>=? fun (unparsed_parameters, ctxt) -> Lwt.return - ( Script_ir_translator.unparse_ty ~loc:Micheline.dummy_location ctxt tp + ( Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt tp >>? fun (ty, ctxt) -> let unparsed_parameters = Micheline.Seq (Micheline.dummy_location, [unparsed_parameters; ty]) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 401d2a7c77f8..ff050082abf0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -146,150 +146,6 @@ let check_kind kinds expr = let loc = location expr in error (Invalid_kind (loc, kinds, kind)) -(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*) - -(* This part contains the unparsing that does not depend on parsing - (everything that cannot contain a lambda). The rest is located at - the end of the file. *) - -let unparse_memo_size ~loc memo_size = - let z = Sapling.Memo_size.unparse_to_z memo_size in - Int (loc, z) - -let rec unparse_ty_and_entrypoints_uncarbonated : - type a ac loc. - loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = - fun ~loc ty {nested = nested_entrypoints; at_node} -> - let name, args = - match ty with - | Unit_t -> (T_unit, []) - | Int_t -> (T_int, []) - | Nat_t -> (T_nat, []) - | Signature_t -> (T_signature, []) - | String_t -> (T_string, []) - | Bytes_t -> (T_bytes, []) - | Mutez_t -> (T_mutez, []) - | Bool_t -> (T_bool, []) - | Key_hash_t -> (T_key_hash, []) - | Key_t -> (T_key, []) - | Timestamp_t -> (T_timestamp, []) - | Address_t -> (T_address, []) - | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, []) - | Operation_t -> (T_operation, []) - | Chain_id_t -> (T_chain_id, []) - | Never_t -> (T_never, []) - | Bls12_381_g1_t -> (T_bls12_381_g1, []) - | Bls12_381_g2_t -> (T_bls12_381_g2, []) - | Bls12_381_fr_t -> (T_bls12_381_fr, []) - | Contract_t (ut, _meta) -> - let t = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_contract, [t]) - | Pair_t (utl, utr, _meta, _) -> ( - let tl = - unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) - (* Note that the folding does not happen if the pair on the right has an - annotation because this annotation would be lost *) - match tr with - | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts) - | _ -> (T_pair, [tl; tr])) - | Union_t (utl, utr, _meta, _) -> - let entrypoints_l, entrypoints_r = - match nested_entrypoints with - | Entrypoints_None -> (no_entrypoints, no_entrypoints) - | Entrypoints_Union {left; right} -> (left, right) - in - let tl = - unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r - in - (T_or, [tl; tr]) - | Lambda_t (uta, utr, _meta) -> - let ta = - unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints - in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_lambda, [ta; tr]) - | Option_t (ut, _meta, _) -> - let ut = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_option, [ut]) - | List_t (ut, _meta) -> - let t = - unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints - in - (T_list, [t]) - | Ticket_t (ut, _meta) -> - let t = unparse_comparable_ty_uncarbonated ~loc ut in - (T_ticket, [t]) - | Set_t (ut, _meta) -> - let t = unparse_comparable_ty_uncarbonated ~loc ut in - (T_set, [t]) - | Map_t (uta, utr, _meta) -> - let ta = unparse_comparable_ty_uncarbonated ~loc uta in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_map, [ta; tr]) - | Big_map_t (uta, utr, _meta) -> - let ta = unparse_comparable_ty_uncarbonated ~loc uta in - let tr = - unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints - in - (T_big_map, [ta; tr]) - | Sapling_transaction_t memo_size -> - (T_sapling_transaction, [unparse_memo_size ~loc memo_size]) - | Sapling_transaction_deprecated_t memo_size -> - (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size]) - | Sapling_state_t memo_size -> - (T_sapling_state, [unparse_memo_size ~loc memo_size]) - | Chest_key_t -> (T_chest_key, []) - | Chest_t -> (T_chest, []) - in - let annot = - match at_node with - | None -> [] - | Some {name; original_type_expr = _} -> - [Entrypoint.unparse_as_field_annot name] - in - Prim (loc, name, args, annot) - -and unparse_comparable_ty_uncarbonated : - type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = - fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints - -let unparse_ty_uncarbonated ~loc ty = - unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints - -let unparse_ty ~loc ctxt ty = - Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> - (unparse_ty_uncarbonated ~loc ty, ctxt) - -let unparse_parameter_ty ~loc ctxt ty ~entrypoints = - Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> - (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt) - -let serialize_ty_for_error ty = - (* - Types are bounded by [Constants.michelson_maximum_type_size], so - [unparse_ty_uncarbonated] and [strip_locations] are bounded in time. - - It is hence OK to use them in errors that are not caught in the validation - (only once in apply). - *) - unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations - let check_comparable : type a ac. Script.location -> (a, ac) ty -> (ac, Dependent_bool.yes) eq tzresult = @@ -297,281 +153,9 @@ let check_comparable : match is_comparable ty with | Yes -> ok Eq | No -> - let t = serialize_ty_for_error ty in + let t = Script_ir_unparser.serialize_ty_for_error ty in error (Comparable_type_expected (loc, t)) -let rec unparse_stack_uncarbonated : - type a s. (a, s) stack_ty -> Script.expr list = function - | Bot_t -> [] - | Item_t (ty, rest) -> - let uty = unparse_ty_uncarbonated ~loc:() ty in - let urest = unparse_stack_uncarbonated rest in - strip_locations uty :: urest - -let serialize_stack_for_error ctxt stack_ty = - match Gas.level ctxt with - | Unaccounted -> unparse_stack_uncarbonated stack_ty - | Limited _ -> [] - -let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt) - -let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) - -let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) - -let unparse_string ~loc ctxt s = - ok (String (loc, Script_string.to_string s), ctxt) - -let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt) - -let unparse_bool ~loc ctxt b = - ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) - -let unparse_timestamp ~loc ctxt mode t = - match mode with - | Optimized | Optimized_legacy -> - ok (Int (loc, Script_timestamp.to_zint t), ctxt) - | Readable -> ( - Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt -> - match Script_timestamp.to_notation t with - | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt) - | Some s -> ok (String (loc, s), ctxt)) - -let unparse_address ~loc ctxt mode {destination; entrypoint} = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) - (destination, entrypoint) - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> - let notation = - Destination.to_b58check destination - ^ Entrypoint.to_address_suffix entrypoint - in - (String (loc, notation), ctxt) - -let unparse_tx_rollup_l2_address ~loc ctxt mode - (tx_address : tx_rollup_l2_address) = - let tx_address = Indexable.to_value tx_address in - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Tx_rollup_l2_address.encoding - tx_address - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> - let b58check = Tx_rollup_l2_address.to_b58check tx_address in - (String (loc, b58check), ctxt) - -let unparse_contract ~loc ctxt mode typed_contract = - let destination = Typed_contract.destination typed_contract in - let entrypoint = Typed_contract.entrypoint typed_contract in - let address = {destination; entrypoint} in - unparse_address ~loc ctxt mode address - -let unparse_signature ~loc ctxt mode s = - let s = Script_signature.get s in - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt -> - let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt -> - (String (loc, Signature.to_b58check s), ctxt) - -let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) - -let unparse_key ~loc ctxt mode k = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt -> - (String (loc, Signature.Public_key.to_b58check k), ctxt) - -let unparse_key_hash ~loc ctxt mode k = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> - (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) - -(* Operations are only unparsed during the production of execution traces of - the interpreter. *) -let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = - let iop = Apply_internal_results.packed_internal_operation piop in - let bytes = - Data_encoding.Binary.to_bytes_exn - Apply_internal_results.internal_operation_encoding - iop - in - Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> - (Bytes (loc, bytes), ctxt) - -let unparse_chain_id ~loc ctxt mode chain_id = - match mode with - | Optimized | Optimized_legacy -> - Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id - in - (Bytes (loc, bytes), ctxt) - | Readable -> - Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt -> - (String (loc, Script_chain_id.to_b58check chain_id), ctxt) - -let unparse_bls12_381_g1 ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt -> - let bytes = Script_bls.G1.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_bls12_381_g2 ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt -> - let bytes = Script_bls.G2.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_bls12_381_fr ~loc ctxt x = - Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt -> - let bytes = Script_bls.Fr.to_bytes x in - (Bytes (loc, bytes), ctxt) - -let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = - Lwt.return - ( Gas.consume ctxt unparse_cost >|? fun ctxt -> - let bytes = Data_encoding.Binary.to_bytes_exn encoding s in - (Bytes (loc, bytes), ctxt) ) - -(* -- Unparsing data of complex types -- *) - -type ('ty, 'depth) comb_witness = - | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness - | Comb_Any : (_, _) comb_witness - -let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode - (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = - unparse_l ctxt l >>=? fun (l, ctxt) -> - unparse_r ctxt r >|=? fun (r, ctxt) -> - (* Fold combs. - For combs, three notations are supported: - - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], - - b) [Pair x1 x2 ... xn-1 xn], and - - c) [{x1; x2; ...; xn-1; xn}]. - In readable mode, we always use b), - in optimized mode we use the shortest to serialize: - - for n=2, [Pair x1 x2], - - for n=3, [Pair x1 (Pair x2 x3)], - - for n>=4, [{x1; x2; ...; xn}]. - *) - let res = - match (mode, r_comb_witness, r) with - | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> - (* Optimized case n > 4 *) - Micheline.Seq (loc, l :: r) - | ( Optimized, - Comb_Pair (Comb_Pair _), - Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> - (* Optimized case n = 4 *) - Micheline.Seq (loc, [l; x2; x3; x4]) - | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> - (* Readable case n > 2 *) - Prim (loc, D_Pair, l :: xs, []) - | _ -> - (* The remaining cases are: - - Optimized n = 2, - - Optimized n = 3, and - - Readable n = 2, - - Optimized_legacy, any n *) - Prim (loc, D_Pair, [l; r], []) - in - (res, ctxt) - -let unparse_union ~loc unparse_l unparse_r ctxt = function - | L l -> - unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt) - | R r -> - unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt) - -let unparse_option ~loc unparse_v ctxt = function - | Some v -> - unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt) - | None -> return (Prim (loc, D_None, [], []), ctxt) - -(* -- Unparsing data of comparable types -- *) - -let comb_witness2 : - type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function - | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any) - | Pair_t _ -> Comb_Pair Comb_Any - | _ -> Comb_Any - -let rec unparse_comparable_data : - type a loc. - loc:loc -> - context -> - unparsing_mode -> - a comparable_ty -> - a -> - (loc Script.michelson_node * context) tzresult Lwt.t = - fun ~loc ctxt mode ty a -> - (* No need for stack_depth here. Unlike [unparse_data], - [unparse_comparable_data] doesn't call [unparse_code]. - The stack depth is bounded by the type depth, currently bounded - by 1000 (michelson_maximum_type_size). *) - Gas.consume ctxt Unparse_costs.unparse_data_cycle - (* We could have a smaller cost but let's keep it consistent with - [unparse_data] for now. *) - >>?= - fun ctxt -> - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Chain_id_t, chain_id -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Pair_t (tl, tr, _, YesYes), pair -> - let r_witness = comb_witness2 tr in - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, YesYes), v -> - let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in - let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, Yes), v -> - let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in - unparse_option ~loc unparse_v ctxt v - | Never_t, _ -> . - let pack_node unparsed ctxt = Gas.consume ctxt (Script.strip_locations_cost unparsed) >>? fun ctxt -> let bytes = @@ -5270,263 +4854,15 @@ let list_entrypoints_uncarbonated (type full fullc) (full : (full, fullc) ty) in fold_tree full entrypoints.root [] reachable ([], init) -(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*) - -(* -- Unparsing data of any type -- *) +include Data_unparser (struct + type nonrec type_logger = type_logger -let rec unparse_data : - type a ac. - context -> - stack_depth:int -> - unparsing_mode -> - (a, ac) ty -> - a -> - (Script.node * context) tzresult Lwt.t = - fun ctxt ~stack_depth mode ty a -> - Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt -> - let non_terminal_recursion ctxt mode ty a = - if Compare.Int.(stack_depth > 10_000) then - fail Unparsing_too_many_recursive_calls - else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a - in - let loc = Micheline.dummy_location in - match (ty, a) with - | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v - | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v - | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v - | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s - | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s - | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b - | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t - | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address - | Tx_rollup_l2_address_t, address -> - Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address - | Contract_t _, contract -> - Lwt.return @@ unparse_contract ~loc ctxt mode contract - | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s - | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v - | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k - | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k - | Operation_t, operation -> - Lwt.return @@ unparse_operation ~loc ctxt operation - | Chain_id_t, chain_id -> - Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id - | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x - | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x - | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x - | Pair_t (tl, tr, _, _), pair -> - let r_witness = comb_witness2 tr in - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair - | Union_t (tl, tr, _, _), v -> - let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in - let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in - unparse_union ~loc unparse_l unparse_r ctxt v - | Option_t (t, _, _), v -> - let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in - unparse_option ~loc unparse_v ctxt v - | List_t (t, _), items -> - List.fold_left_es - (fun (l, ctxt) element -> - non_terminal_recursion ctxt mode t element - >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) - ([], ctxt) - items.elements - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) - | Ticket_t (t, _), {ticketer; contents; amount} -> - (* ideally we would like to allow a little overhead here because it is only used for unparsing *) - opened_ticket_type loc t >>?= fun t -> - let destination : Destination.t = Contract ticketer in - let addr = {destination; entrypoint = Entrypoint.default} in - (unparse_data [@tailcall]) - ctxt - ~stack_depth - mode - t - (addr, (contents, amount)) - | Set_t (t, _), set -> - List.fold_left_es - (fun (l, ctxt) item -> - unparse_comparable_data ~loc ctxt mode t item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - (Script_set.fold (fun e acc -> e :: acc) set []) - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Map_t (kt, vt, _), map -> - let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} - when Compare.Int.( = ) size 0 -> - return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) - | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] - in - let items = - (* Sort the items in Michelson comparison order and not in key - hash order. This code path is only exercised for tracing, - so we don't bother carbonating this sort operation - precisely. Also, the sort uses a reverse compare because - [unparse_items] will reverse the result. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - (* this can't fail if the original type is well-formed - because [option vt] is always strictly smaller than [big_map kt vt] *) - option_t loc vt >>?= fun vt -> - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> - ( Micheline.Prim - ( loc, - D_Pair, - [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], - [] ), - ctxt ) - | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> - let items = - Big_map_overlay.fold - (fun _ (k, v) acc -> - match v with None -> acc | Some v -> (k, v) :: acc) - map - [] - in - let items = - (* See note above. *) - List.sort - (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) - items - in - unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items - >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) - | Lambda_t _, Lam (_, original_code) -> - unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code - | Never_t, _ -> . - | Sapling_transaction_t _, s -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s - in - (Bytes (loc, bytes), ctxt) ) - | Sapling_transaction_deprecated_t _, s -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) - >|? fun ctxt -> - let bytes = - Data_encoding.Binary.to_bytes_exn - Sapling.Legacy.transaction_encoding - s - in - (Bytes (loc, bytes), ctxt) ) - | Sapling_state_t _, {id; diff; _} -> - Lwt.return - ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> - ( (match diff with - | {commitments_and_ciphertexts = []; nullifiers = []} -> ( - match id with - | None -> Micheline.Seq (loc, []) - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Int (loc, id)) - | diff -> ( - let diff_bytes = - Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff - in - let unparsed_diff = Bytes (loc, diff_bytes) in - match id with - | None -> unparsed_diff - | Some id -> - let id = Sapling.Id.unparse_to_z id in - Micheline.Prim - (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), - ctxt ) ) - | Chest_key_t, s -> - unparse_with_data_encoding - ~loc - ctxt - s - Unparse_costs.chest_key - Script_timelock.chest_key_encoding - | Chest_t, s -> - unparse_with_data_encoding - ~loc - ctxt - s - (Unparse_costs.chest - ~plaintext_size:(Script_timelock.get_plaintext_size s)) - Script_timelock.chest_encoding + let opened_ticket_type = opened_ticket_type -and unparse_items : - type k v vc. - context -> - stack_depth:int -> - unparsing_mode -> - k comparable_ty -> - (v, vc) ty -> - (k * v) list -> - (Script.node list * context) tzresult Lwt.t = - fun ctxt ~stack_depth mode kt vt items -> - List.fold_left_es - (fun (l, ctxt) (k, v) -> - let loc = Micheline.dummy_location in - unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v - >|=? fun (value, ctxt) -> (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) - ([], ctxt) - items + let parse_packable_ty = parse_packable_ty -and unparse_code ctxt ~stack_depth mode code = - let legacy = true in - Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> - let non_terminal_recursion ctxt mode code = - if Compare.Int.(stack_depth > 10_000) then - fail Unparsing_too_many_recursive_calls - else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code - in - match code with - | Prim (loc, I_PUSH, [ty; data], annot) -> - parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty - >>?= fun (Ex_ty t, ctxt) -> - let allow_forged = - false - (* Forgeable in PUSH data are already forbidden at parsing, - the only case for which this matters is storing a lambda resulting - from APPLYing a non-forgeable but this cannot happen either as long - as all packable values are also forgeable. *) - in - parse_data - ctxt - ~stack_depth:(stack_depth + 1) - ~legacy - ~allow_forged - t - data - >>=? fun (data, ctxt) -> - unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data - >>=? fun (data, ctxt) -> - return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) - | Seq (loc, items) -> - List.fold_left_es - (fun (l, ctxt) item -> - non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - items - >>=? fun (items, ctxt) -> - return (Micheline.Seq (loc, List.rev items), ctxt) - | Prim (loc, prim, items, annot) -> - List.fold_left_es - (fun (l, ctxt) item -> - non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> - (item :: l, ctxt)) - ([], ctxt) - items - >>=? fun (items, ctxt) -> - return (Prim (loc, prim, List.rev items, annot), ctxt) - | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) + let parse_data = parse_data +end) let parse_and_unparse_script_unaccounted ctxt ~legacy ~allow_forged_in_storage mode ~normalize_types {code; storage} = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 90b10b7b91f8..5407b328d25c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -42,7 +42,7 @@ careful not to accidentally quantify 'a universally, that is "for all 'a, 'a ty exists", otherwise you'll get an annoying error about 'a trying to escape it's scope. We do this by hiding 'a in an existential type. This is what - ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. + ex_comparable_ty, ex_ty, ex_stack_ty, etc. do. 2. A set of functions dealing with high-level Michelson types: This module also provides functions for interacting with the list, map, @@ -200,14 +200,6 @@ val unparse_data : 'a -> (Script.node * context) tzresult Lwt.t -val unparse_comparable_data : - loc:'loc -> - context -> - Script_ir_unparser.unparsing_mode -> - 'a Script_typed_ir.comparable_ty -> - 'a -> - ('loc Script.michelson_node * context) tzresult Lwt.t - val unparse_code : context -> Script_ir_unparser.unparsing_mode -> @@ -294,22 +286,9 @@ val parse_ty : Script.node -> (ex_ty * context) tzresult -val unparse_ty : - loc:'loc -> - context -> - ('a, _) Script_typed_ir.ty -> - ('loc Script.michelson_node * context) tzresult - val parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult Lwt.t -val unparse_parameter_ty : - loc:'loc -> - context -> - ('a, _) Script_typed_ir.ty -> - entrypoints:'a Script_typed_ir.entrypoints -> - ('loc Script.michelson_node * context) tzresult - (** High-level function to typecheck a Michelson script. This function is not used for validating operations but only for the [typecheck_code] RPC. @@ -322,8 +301,6 @@ val typecheck_code : Script.expr -> (type_map * context) tzresult Lwt.t -val serialize_ty_for_error : ('a, _) Script_typed_ir.ty -> Script.expr - val parse_code : ?type_logger:type_logger -> context -> diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.ml b/src/proto_alpha/lib_protocol/script_ir_unparser.ml index 4e3bd2b643ee..306f15962ab0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.ml +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.ml @@ -23,9 +23,711 @@ (* *) (*****************************************************************************) -(* open Alpha_context *) -(* open Micheline *) -(* open Script_typed_ir *) -(* module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing *) +open Alpha_context +open Micheline +open Script_typed_ir +open Michelson_v1_primitives +module Unparse_costs = Michelson_v1_gas.Cost_of.Unparsing type unparsing_mode = Optimized | Readable | Optimized_legacy + +(* This part contains the unparsing that does not depend on parsing + (everything that cannot contain a lambda). The rest is located at + the end of the file. *) + +let unparse_memo_size ~loc memo_size = + let z = Sapling.Memo_size.unparse_to_z memo_size in + Int (loc, z) + +let rec unparse_ty_and_entrypoints_uncarbonated : + type a ac loc. + loc:loc -> (a, ac) ty -> a entrypoints_node -> loc Script.michelson_node = + fun ~loc ty {nested = nested_entrypoints; at_node} -> + let name, args = + match ty with + | Unit_t -> (T_unit, []) + | Int_t -> (T_int, []) + | Nat_t -> (T_nat, []) + | Signature_t -> (T_signature, []) + | String_t -> (T_string, []) + | Bytes_t -> (T_bytes, []) + | Mutez_t -> (T_mutez, []) + | Bool_t -> (T_bool, []) + | Key_hash_t -> (T_key_hash, []) + | Key_t -> (T_key, []) + | Timestamp_t -> (T_timestamp, []) + | Address_t -> (T_address, []) + | Tx_rollup_l2_address_t -> (T_tx_rollup_l2_address, []) + | Operation_t -> (T_operation, []) + | Chain_id_t -> (T_chain_id, []) + | Never_t -> (T_never, []) + | Bls12_381_g1_t -> (T_bls12_381_g1, []) + | Bls12_381_g2_t -> (T_bls12_381_g2, []) + | Bls12_381_fr_t -> (T_bls12_381_fr, []) + | Contract_t (ut, _meta) -> + let t = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_contract, [t]) + | Pair_t (utl, utr, _meta, _) -> ( + let tl = + unparse_ty_and_entrypoints_uncarbonated ~loc utl no_entrypoints + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (* Fold [pair a1 (pair ... (pair an-1 an))] into [pair a1 ... an] *) + (* Note that the folding does not happen if the pair on the right has an + annotation because this annotation would be lost *) + match tr with + | Prim (_, T_pair, ts, []) -> (T_pair, tl :: ts) + | _ -> (T_pair, [tl; tr])) + | Union_t (utl, utr, _meta, _) -> + let entrypoints_l, entrypoints_r = + match nested_entrypoints with + | Entrypoints_None -> (no_entrypoints, no_entrypoints) + | Entrypoints_Union {left; right} -> (left, right) + in + let tl = + unparse_ty_and_entrypoints_uncarbonated ~loc utl entrypoints_l + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr entrypoints_r + in + (T_or, [tl; tr]) + | Lambda_t (uta, utr, _meta) -> + let ta = + unparse_ty_and_entrypoints_uncarbonated ~loc uta no_entrypoints + in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_lambda, [ta; tr]) + | Option_t (ut, _meta, _) -> + let ut = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_option, [ut]) + | List_t (ut, _meta) -> + let t = + unparse_ty_and_entrypoints_uncarbonated ~loc ut no_entrypoints + in + (T_list, [t]) + | Ticket_t (ut, _meta) -> + let t = unparse_comparable_ty_uncarbonated ~loc ut in + (T_ticket, [t]) + | Set_t (ut, _meta) -> + let t = unparse_comparable_ty_uncarbonated ~loc ut in + (T_set, [t]) + | Map_t (uta, utr, _meta) -> + let ta = unparse_comparable_ty_uncarbonated ~loc uta in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_map, [ta; tr]) + | Big_map_t (uta, utr, _meta) -> + let ta = unparse_comparable_ty_uncarbonated ~loc uta in + let tr = + unparse_ty_and_entrypoints_uncarbonated ~loc utr no_entrypoints + in + (T_big_map, [ta; tr]) + | Sapling_transaction_t memo_size -> + (T_sapling_transaction, [unparse_memo_size ~loc memo_size]) + | Sapling_transaction_deprecated_t memo_size -> + (T_sapling_transaction_deprecated, [unparse_memo_size ~loc memo_size]) + | Sapling_state_t memo_size -> + (T_sapling_state, [unparse_memo_size ~loc memo_size]) + | Chest_key_t -> (T_chest_key, []) + | Chest_t -> (T_chest, []) + in + let annot = + match at_node with + | None -> [] + | Some {name; original_type_expr = _} -> + [Entrypoint.unparse_as_field_annot name] + in + Prim (loc, name, args, annot) + +and unparse_comparable_ty_uncarbonated : + type a loc. loc:loc -> a comparable_ty -> loc Script.michelson_node = + fun ~loc ty -> unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints + +let unparse_ty_uncarbonated ~loc ty = + unparse_ty_and_entrypoints_uncarbonated ~loc ty no_entrypoints + +let unparse_ty ~loc ctxt ty = + Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> + (unparse_ty_uncarbonated ~loc ty, ctxt) + +let unparse_parameter_ty ~loc ctxt ty ~entrypoints = + Gas.consume ctxt (Unparse_costs.unparse_type ty) >|? fun ctxt -> + (unparse_ty_and_entrypoints_uncarbonated ~loc ty entrypoints.root, ctxt) + +let serialize_ty_for_error ty = + (* + Types are bounded by [Constants.michelson_maximum_type_size], so + [unparse_ty_uncarbonated] and [strip_locations] are bounded in time. + + It is hence OK to use them in errors that are not caught in the validation + (only once in apply). + *) + unparse_ty_uncarbonated ~loc:() ty |> Micheline.strip_locations + +let rec unparse_stack_uncarbonated : + type a s. (a, s) stack_ty -> Script.expr list = function + | Bot_t -> [] + | Item_t (ty, rest) -> + let uty = unparse_ty_uncarbonated ~loc:() ty in + let urest = unparse_stack_uncarbonated rest in + strip_locations uty :: urest + +let serialize_stack_for_error ctxt stack_ty = + match Gas.level ctxt with + | Unaccounted -> unparse_stack_uncarbonated stack_ty + | Limited _ -> [] + +let unparse_unit ~loc ctxt () = ok (Prim (loc, D_Unit, [], []), ctxt) + +let unparse_int ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) + +let unparse_nat ~loc ctxt v = ok (Int (loc, Script_int.to_zint v), ctxt) + +let unparse_string ~loc ctxt s = + ok (String (loc, Script_string.to_string s), ctxt) + +let unparse_bytes ~loc ctxt s = ok (Bytes (loc, s), ctxt) + +let unparse_bool ~loc ctxt b = + ok (Prim (loc, (if b then D_True else D_False), [], []), ctxt) + +let unparse_timestamp ~loc ctxt mode t = + match mode with + | Optimized | Optimized_legacy -> + ok (Int (loc, Script_timestamp.to_zint t), ctxt) + | Readable -> ( + Gas.consume ctxt Unparse_costs.timestamp_readable >>? fun ctxt -> + match Script_timestamp.to_notation t with + | None -> ok (Int (loc, Script_timestamp.to_zint t), ctxt) + | Some s -> ok (String (loc, s), ctxt)) + +let unparse_address ~loc ctxt mode {destination; entrypoint} = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Data_encoding.(tup2 Destination.encoding Entrypoint.value_encoding) + (destination, entrypoint) + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> + let notation = + Destination.to_b58check destination + ^ Entrypoint.to_address_suffix entrypoint + in + (String (loc, notation), ctxt) + +let unparse_tx_rollup_l2_address ~loc ctxt mode + (tx_address : tx_rollup_l2_address) = + let tx_address = Indexable.to_value tx_address in + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.contract_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Tx_rollup_l2_address.encoding + tx_address + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.contract_readable >|? fun ctxt -> + let b58check = Tx_rollup_l2_address.to_b58check tx_address in + (String (loc, b58check), ctxt) + +let unparse_contract ~loc ctxt mode typed_contract = + let destination = Typed_contract.destination typed_contract in + let entrypoint = Typed_contract.entrypoint typed_contract in + let address = {destination; entrypoint} in + unparse_address ~loc ctxt mode address + +let unparse_signature ~loc ctxt mode s = + let s = Script_signature.get s in + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.signature_optimized >|? fun ctxt -> + let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.signature_readable >|? fun ctxt -> + (String (loc, Signature.to_b58check s), ctxt) + +let unparse_mutez ~loc ctxt v = ok (Int (loc, Z.of_int64 (Tez.to_mutez v)), ctxt) + +let unparse_key ~loc ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.public_key_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.public_key_readable >|? fun ctxt -> + (String (loc, Signature.Public_key.to_b58check k), ctxt) + +let unparse_key_hash ~loc ctxt mode k = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.key_hash_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.key_hash_readable >|? fun ctxt -> + (String (loc, Signature.Public_key_hash.to_b58check k), ctxt) + +(* Operations are only unparsed during the production of execution traces of + the interpreter. *) +let unparse_operation ~loc ctxt {piop; lazy_storage_diff = _} = + let iop = Apply_internal_results.packed_internal_operation piop in + let bytes = + Data_encoding.Binary.to_bytes_exn + Apply_internal_results.internal_operation_encoding + iop + in + Gas.consume ctxt (Unparse_costs.operation bytes) >|? fun ctxt -> + (Bytes (loc, bytes), ctxt) + +let unparse_chain_id ~loc ctxt mode chain_id = + match mode with + | Optimized | Optimized_legacy -> + Gas.consume ctxt Unparse_costs.chain_id_optimized >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Script_chain_id.encoding chain_id + in + (Bytes (loc, bytes), ctxt) + | Readable -> + Gas.consume ctxt Unparse_costs.chain_id_readable >|? fun ctxt -> + (String (loc, Script_chain_id.to_b58check chain_id), ctxt) + +let unparse_bls12_381_g1 ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g1 >|? fun ctxt -> + let bytes = Script_bls.G1.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_bls12_381_g2 ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_g2 >|? fun ctxt -> + let bytes = Script_bls.G2.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_bls12_381_fr ~loc ctxt x = + Gas.consume ctxt Unparse_costs.bls12_381_fr >|? fun ctxt -> + let bytes = Script_bls.Fr.to_bytes x in + (Bytes (loc, bytes), ctxt) + +let unparse_with_data_encoding ~loc ctxt s unparse_cost encoding = + Lwt.return + ( Gas.consume ctxt unparse_cost >|? fun ctxt -> + let bytes = Data_encoding.Binary.to_bytes_exn encoding s in + (Bytes (loc, bytes), ctxt) ) + +(* -- Unparsing data of complex types -- *) + +type ('ty, 'depth) comb_witness = + | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness + | Comb_Any : (_, _) comb_witness + +let unparse_pair (type r) ~loc unparse_l unparse_r ctxt mode + (r_comb_witness : (r, unit -> unit -> _) comb_witness) (l, (r : r)) = + unparse_l ctxt l >>=? fun (l, ctxt) -> + unparse_r ctxt r >|=? fun (r, ctxt) -> + (* Fold combs. + For combs, three notations are supported: + - a) [Pair x1 (Pair x2 ... (Pair xn-1 xn) ...)], + - b) [Pair x1 x2 ... xn-1 xn], and + - c) [{x1; x2; ...; xn-1; xn}]. + In readable mode, we always use b), + in optimized mode we use the shortest to serialize: + - for n=2, [Pair x1 x2], + - for n=3, [Pair x1 (Pair x2 x3)], + - for n>=4, [{x1; x2; ...; xn}]. + *) + let res = + match (mode, r_comb_witness, r) with + | Optimized, Comb_Pair _, Micheline.Seq (_, r) -> + (* Optimized case n > 4 *) + Micheline.Seq (loc, l :: r) + | ( Optimized, + Comb_Pair (Comb_Pair _), + Prim (_, D_Pair, [x2; Prim (_, D_Pair, [x3; x4], [])], []) ) -> + (* Optimized case n = 4 *) + Micheline.Seq (loc, [l; x2; x3; x4]) + | Readable, Comb_Pair _, Prim (_, D_Pair, xs, []) -> + (* Readable case n > 2 *) + Prim (loc, D_Pair, l :: xs, []) + | _ -> + (* The remaining cases are: + - Optimized n = 2, + - Optimized n = 3, and + - Readable n = 2, + - Optimized_legacy, any n *) + Prim (loc, D_Pair, [l; r], []) + in + (res, ctxt) + +let unparse_union ~loc unparse_l unparse_r ctxt = function + | L l -> + unparse_l ctxt l >|=? fun (l, ctxt) -> (Prim (loc, D_Left, [l], []), ctxt) + | R r -> + unparse_r ctxt r >|=? fun (r, ctxt) -> (Prim (loc, D_Right, [r], []), ctxt) + +let unparse_option ~loc unparse_v ctxt = function + | Some v -> + unparse_v ctxt v >|=? fun (v, ctxt) -> (Prim (loc, D_Some, [v], []), ctxt) + | None -> return (Prim (loc, D_None, [], []), ctxt) + +(* -- Unparsing data of comparable types -- *) + +let comb_witness2 : + type t tc. (t, tc) ty -> (t, unit -> unit -> unit) comb_witness = function + | Pair_t (_, Pair_t _, _, _) -> Comb_Pair (Comb_Pair Comb_Any) + | Pair_t _ -> Comb_Pair Comb_Any + | _ -> Comb_Any + +let rec unparse_comparable_data : + type a loc. + loc:loc -> + context -> + unparsing_mode -> + a comparable_ty -> + a -> + (loc Script.michelson_node * context) tzresult Lwt.t = + fun ~loc ctxt mode ty a -> + (* No need for stack_depth here. Unlike [unparse_data], + [unparse_comparable_data] doesn't call [unparse_code]. + The stack depth is bounded by the type depth, currently bounded + by 1000 (michelson_maximum_type_size). *) + Gas.consume ctxt Unparse_costs.unparse_data_cycle + (* We could have a smaller cost but let's keep it consistent with + [unparse_data] for now. *) + >>?= + fun ctxt -> + match (ty, a) with + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> + Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Chain_id_t, chain_id -> + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id + | Pair_t (tl, tr, _, YesYes), pair -> + let r_witness = comb_witness2 tr in + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + | Union_t (tl, tr, _, YesYes), v -> + let unparse_l ctxt v = unparse_comparable_data ~loc ctxt mode tl v in + let unparse_r ctxt v = unparse_comparable_data ~loc ctxt mode tr v in + unparse_union ~loc unparse_l unparse_r ctxt v + | Option_t (t, _, Yes), v -> + let unparse_v ctxt v = unparse_comparable_data ~loc ctxt mode t v in + unparse_option ~loc unparse_v ctxt v + | Never_t, _ -> . + +(* -- Unparsing data of any type -- *) + +module type MICHELSON_PARSER = sig + type type_logger + + val opened_ticket_type : + Script.location -> + 'a comparable_ty -> + (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty + tzresult + + val parse_packable_ty : + context -> + stack_depth:int -> + legacy:bool -> + Script.node -> + (ex_ty * context) tzresult + + val parse_data : + ?type_logger:type_logger -> + stack_depth:int -> + context -> + legacy:bool -> + allow_forged:bool -> + ('a, 'ac) ty -> + Script.node -> + ('a * t) tzresult Lwt.t +end + +module Data_unparser (P : MICHELSON_PARSER) = struct + let rec unparse_data : + type a ac. + context -> + stack_depth:int -> + unparsing_mode -> + (a, ac) ty -> + a -> + (Script.node * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode ty a -> + Gas.consume ctxt Unparse_costs.unparse_data_cycle >>?= fun ctxt -> + let non_terminal_recursion ctxt mode ty a = + if Compare.Int.(stack_depth > 10_000) then + fail Script_tc_errors.Unparsing_too_many_recursive_calls + else unparse_data ctxt ~stack_depth:(stack_depth + 1) mode ty a + in + let loc = Micheline.dummy_location in + match (ty, a) with + | Unit_t, v -> Lwt.return @@ unparse_unit ~loc ctxt v + | Int_t, v -> Lwt.return @@ unparse_int ~loc ctxt v + | Nat_t, v -> Lwt.return @@ unparse_nat ~loc ctxt v + | String_t, s -> Lwt.return @@ unparse_string ~loc ctxt s + | Bytes_t, s -> Lwt.return @@ unparse_bytes ~loc ctxt s + | Bool_t, b -> Lwt.return @@ unparse_bool ~loc ctxt b + | Timestamp_t, t -> Lwt.return @@ unparse_timestamp ~loc ctxt mode t + | Address_t, address -> Lwt.return @@ unparse_address ~loc ctxt mode address + | Tx_rollup_l2_address_t, address -> + Lwt.return @@ unparse_tx_rollup_l2_address ~loc ctxt mode address + | Contract_t _, contract -> + Lwt.return @@ unparse_contract ~loc ctxt mode contract + | Signature_t, s -> Lwt.return @@ unparse_signature ~loc ctxt mode s + | Mutez_t, v -> Lwt.return @@ unparse_mutez ~loc ctxt v + | Key_t, k -> Lwt.return @@ unparse_key ~loc ctxt mode k + | Key_hash_t, k -> Lwt.return @@ unparse_key_hash ~loc ctxt mode k + | Operation_t, operation -> + Lwt.return @@ unparse_operation ~loc ctxt operation + | Chain_id_t, chain_id -> + Lwt.return @@ unparse_chain_id ~loc ctxt mode chain_id + | Bls12_381_g1_t, x -> Lwt.return @@ unparse_bls12_381_g1 ~loc ctxt x + | Bls12_381_g2_t, x -> Lwt.return @@ unparse_bls12_381_g2 ~loc ctxt x + | Bls12_381_fr_t, x -> Lwt.return @@ unparse_bls12_381_fr ~loc ctxt x + | Pair_t (tl, tr, _, _), pair -> + let r_witness = comb_witness2 tr in + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_pair ~loc unparse_l unparse_r ctxt mode r_witness pair + | Union_t (tl, tr, _, _), v -> + let unparse_l ctxt v = non_terminal_recursion ctxt mode tl v in + let unparse_r ctxt v = non_terminal_recursion ctxt mode tr v in + unparse_union ~loc unparse_l unparse_r ctxt v + | Option_t (t, _, _), v -> + let unparse_v ctxt v = non_terminal_recursion ctxt mode t v in + unparse_option ~loc unparse_v ctxt v + | List_t (t, _), items -> + List.fold_left_es + (fun (l, ctxt) element -> + non_terminal_recursion ctxt mode t element + >|=? fun (unparsed, ctxt) -> (unparsed :: l, ctxt)) + ([], ctxt) + items.elements + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, List.rev items), ctxt) + | Ticket_t (t, _), {ticketer; contents; amount} -> + (* ideally we would like to allow a little overhead here because it is only used for unparsing *) + P.opened_ticket_type loc t >>?= fun t -> + let destination : Destination.t = Contract ticketer in + let addr = {destination; entrypoint = Entrypoint.default} in + (unparse_data [@tailcall]) + ctxt + ~stack_depth + mode + t + (addr, (contents, amount)) + | Set_t (t, _), set -> + List.fold_left_es + (fun (l, ctxt) item -> + unparse_comparable_data ~loc ctxt mode t item + >|=? fun (item, ctxt) -> (item :: l, ctxt)) + ([], ctxt) + (Script_set.fold (fun e acc -> e :: acc) set []) + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Map_t (kt, vt, _), map -> + let items = Script_map.fold (fun k v acc -> (k, v) :: acc) map [] in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Big_map_t (_kt, _vt, _), Big_map {id = Some id; diff = {size; _}; _} + when Compare.Int.( = ) size 0 -> + return (Micheline.Int (loc, Big_map.Id.unparse_to_z id), ctxt) + | Big_map_t (kt, vt, _), Big_map {id = Some id; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold (fun _ (k, v) acc -> (k, v) :: acc) map [] + in + let items = + (* Sort the items in Michelson comparison order and not in key + hash order. This code path is only exercised for tracing, + so we don't bother carbonating this sort operation + precisely. Also, the sort uses a reverse compare because + [unparse_items] will reverse the result. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + (* this can't fail if the original type is well-formed + because [option vt] is always strictly smaller than [big_map kt vt] *) + option_t loc vt >>?= fun vt -> + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> + ( Micheline.Prim + ( loc, + D_Pair, + [Int (loc, Big_map.Id.unparse_to_z id); Seq (loc, items)], + [] ), + ctxt ) + | Big_map_t (kt, vt, _), Big_map {id = None; diff = {map; _}; _} -> + let items = + Big_map_overlay.fold + (fun _ (k, v) acc -> + match v with None -> acc | Some v -> (k, v) :: acc) + map + [] + in + let items = + (* See note above. *) + List.sort + (fun (a, _) (b, _) -> Script_comparable.compare_comparable kt b a) + items + in + unparse_items ctxt ~stack_depth:(stack_depth + 1) mode kt vt items + >|=? fun (items, ctxt) -> (Micheline.Seq (loc, items), ctxt) + | Lambda_t _, Lam (_, original_code) -> + unparse_code ctxt ~stack_depth:(stack_depth + 1) mode original_code + | Never_t, _ -> . + | Sapling_transaction_t _, s -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_transaction s) + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn Sapling.transaction_encoding s + in + (Bytes (loc, bytes), ctxt) ) + | Sapling_transaction_deprecated_t _, s -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_transaction_deprecated s) + >|? fun ctxt -> + let bytes = + Data_encoding.Binary.to_bytes_exn + Sapling.Legacy.transaction_encoding + s + in + (Bytes (loc, bytes), ctxt) ) + | Sapling_state_t _, {id; diff; _} -> + Lwt.return + ( Gas.consume ctxt (Unparse_costs.sapling_diff diff) >|? fun ctxt -> + ( (match diff with + | {commitments_and_ciphertexts = []; nullifiers = []} -> ( + match id with + | None -> Micheline.Seq (loc, []) + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Int (loc, id)) + | diff -> ( + let diff_bytes = + Data_encoding.Binary.to_bytes_exn Sapling.diff_encoding diff + in + let unparsed_diff = Bytes (loc, diff_bytes) in + match id with + | None -> unparsed_diff + | Some id -> + let id = Sapling.Id.unparse_to_z id in + Micheline.Prim + (loc, D_Pair, [Int (loc, id); unparsed_diff], []))), + ctxt ) ) + | Chest_key_t, s -> + unparse_with_data_encoding + ~loc + ctxt + s + Unparse_costs.chest_key + Script_timelock.chest_key_encoding + | Chest_t, s -> + unparse_with_data_encoding + ~loc + ctxt + s + (Unparse_costs.chest + ~plaintext_size:(Script_timelock.get_plaintext_size s)) + Script_timelock.chest_encoding + + and unparse_items : + type k v vc. + context -> + stack_depth:int -> + unparsing_mode -> + k comparable_ty -> + (v, vc) ty -> + (k * v) list -> + (Script.node list * context) tzresult Lwt.t = + fun ctxt ~stack_depth mode kt vt items -> + List.fold_left_es + (fun (l, ctxt) (k, v) -> + let loc = Micheline.dummy_location in + unparse_comparable_data ~loc ctxt mode kt k >>=? fun (key, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode vt v + >|=? fun (value, ctxt) -> + (Prim (loc, D_Elt, [key; value], []) :: l, ctxt)) + ([], ctxt) + items + + and unparse_code ctxt ~stack_depth mode code = + let legacy = true in + Gas.consume ctxt Unparse_costs.unparse_instr_cycle >>?= fun ctxt -> + let non_terminal_recursion ctxt mode code = + if Compare.Int.(stack_depth > 10_000) then + fail Script_tc_errors.Unparsing_too_many_recursive_calls + else unparse_code ctxt ~stack_depth:(stack_depth + 1) mode code + in + match code with + | Prim (loc, I_PUSH, [ty; data], annot) -> + P.parse_packable_ty ctxt ~stack_depth:(stack_depth + 1) ~legacy ty + >>?= fun (Ex_ty t, ctxt) -> + let allow_forged = + false + (* Forgeable in PUSH data are already forbidden at parsing, + the only case for which this matters is storing a lambda resulting + from APPLYing a non-forgeable but this cannot happen either as long + as all packable values are also forgeable. *) + in + P.parse_data + ctxt + ~stack_depth:(stack_depth + 1) + ~legacy + ~allow_forged + t + data + >>=? fun (data, ctxt) -> + unparse_data ctxt ~stack_depth:(stack_depth + 1) mode t data + >>=? fun (data, ctxt) -> + return (Prim (loc, I_PUSH, [ty; data], annot), ctxt) + | Seq (loc, items) -> + List.fold_left_es + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> + (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Micheline.Seq (loc, List.rev items), ctxt) + | Prim (loc, prim, items, annot) -> + List.fold_left_es + (fun (l, ctxt) item -> + non_terminal_recursion ctxt mode item >|=? fun (item, ctxt) -> + (item :: l, ctxt)) + ([], ctxt) + items + >>=? fun (items, ctxt) -> + return (Prim (loc, prim, List.rev items, annot), ctxt) + | (Int _ | String _ | Bytes _) as atom -> return (atom, ctxt) +end diff --git a/src/proto_alpha/lib_protocol/script_ir_unparser.mli b/src/proto_alpha/lib_protocol/script_ir_unparser.mli index b2b71e1fb47b..47ff8f3be5eb 100644 --- a/src/proto_alpha/lib_protocol/script_ir_unparser.mli +++ b/src/proto_alpha/lib_protocol/script_ir_unparser.mli @@ -23,6 +23,9 @@ (* *) (*****************************************************************************) +open Alpha_context +open Script_typed_ir + (** Flag that drives unparsing of typed values to nodes. - [Optimized_legacy] must be kept backward-compatible in order to compute valid hashes (of big map keys). @@ -30,3 +33,180 @@ - [Readable] produces with [string] values instead of [bytes] when feasible. *) type unparsing_mode = Optimized | Readable | Optimized_legacy + +(** [('t, 'd) comb_witness] describes types of values belonging to a [comb] + of type ['t] and size ['d]. *) +type ('ty, 'depth) comb_witness = + | Comb_Pair : ('t, 'd) comb_witness -> (_ * 't, unit -> 'd) comb_witness + | Comb_Any : (_, _) comb_witness + +(** [serialize_ty_for_error ty] returns the Micheline representation of [ty] + suitable for rendering in an error message. Does not consume gas, since + when this function is called, the operation must have already failed. *) +val serialize_ty_for_error : ('a, 'b) ty -> Script.expr + +(** [serialize_stack_for_error ctxt stack_ty] returns a Micheline representation of + [stack_ty] as a list of Micheline expressions ONLY IF gas is unlimited + in [ctxt]. Otherwise returns an empty list. *) +val serialize_stack_for_error : context -> ('a, 'b) stack_ty -> Script.expr list + +(** [unparse_ty ~loc ctxt ty] returns the Micheline representation of a given + type and an update context, where gas has been properly consumed. *) +val unparse_ty : + loc:'loc -> + context -> + ('b, 'c) ty -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_comparable_ty_uncarbonated ~loc ty] returns the Michelson + representation of comparable type [ty] without consuming gas. *) +val unparse_comparable_ty_uncarbonated : + loc:'loc -> 'a comparable_ty -> 'loc Script.michelson_node + +(** [unparse_stack_uncarbonated stack_ty] returns the Micheline representation + of [stack_ty]. Does not consume gas. *) +val unparse_stack_uncarbonated : ('a, 's) stack_ty -> Script.expr list + +(** [unparse_parameter_ty ~loc ctxt ty ~entrypoints] is a specialised version of + [unparse_ty], which also analyses [entrypoints] in order to annotate + the returned type with adequate annotations. *) +val unparse_parameter_ty : + loc:'loc -> + context -> + ('a, 'c) ty -> + entrypoints:'a entrypoints -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_g1 : + loc:'loc -> + context -> + Script_bls.G1.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_g2 : + loc:'loc -> + context -> + Script_bls.G2.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_bls12_381_g1 ~loc ctxt bls] returns the Micheline representation + of [bls] and consumes gas from [ctxt]. *) +val unparse_bls12_381_fr : + loc:'loc -> + context -> + Script_bls.Fr.t -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_operation ~loc ctxt op] returns the Micheline representation of + [op] and consumes gas from [ctxt]. Useful only for producing execution + traces in the interpreter. *) +val unparse_operation : + loc:'loc -> + context -> + Script_typed_ir.operation -> + ('loc Script.michelson_node * context, error trace) result + +(** [unparse_with_data_encoding ~loc ctxt v gas_cost enc] returns the bytes + representation of [v] wrapped in [Micheline.Bytes], consuming [gas_cost] + from [ctxt]. *) +val unparse_with_data_encoding : + loc:'loc -> + context -> + 'a -> + Gas.cost -> + 'a Data_encoding.t -> + ('loc Script.michelson_node * context, error trace) result Lwt.t + +(** [unparse_comparable_data ~loc ctxt unparsing_mode ty v] returns the + Micheline representation of [v] of type [ty], consuming gas from + [ctxt]. *) +val unparse_comparable_data : + loc:'loc -> + context -> + unparsing_mode -> + 'a comparable_ty -> + 'a -> + ('loc Script.michelson_node * context) tzresult Lwt.t + +(** [unparse_contract ~loc ctxt unparsin_mode contract] returns a Micheline + representation of a given contract in a given [unparsing_mode]. Consumes + gas [ctxt]. *) +val unparse_contract : + loc:'loc -> + context -> + unparsing_mode -> + 'b typed_contract -> + ('loc Script.michelson_node * context, error trace) result + +(** [MICHESLON_PARSER] signature describes a set of dependencies required to + unparse arbitrary values in the IR. Because some of those values contain + just a Michelson code that does not need to be parsed immediately, + unparsing them requires extracting information from that code – that's + why we depend on the parser here. *) +module type MICHELSON_PARSER = sig + type type_logger + + val opened_ticket_type : + Script.location -> + 'a comparable_ty -> + (address, ('a, Script_int.n Script_int.num) pair) pair comparable_ty + tzresult + + val parse_packable_ty : + context -> + stack_depth:int -> + legacy:bool -> + Script.node -> + (ex_ty * context) tzresult + + val parse_data : + ?type_logger:type_logger -> + stack_depth:int -> + context -> + legacy:bool -> + allow_forged:bool -> + ('a, 'ac) ty -> + Script.node -> + ('a * t) tzresult Lwt.t +end + +module Data_unparser : functor (P : MICHELSON_PARSER) -> sig + (** [unparse_data ctxt ~stack_depth unparsing_mode ty data] returns the + Micheline representation of [data] of type [ty], consuming an appropriate + amount of gas from [ctxt]. *) + val unparse_data : + context -> + stack_depth:int -> + unparsing_mode -> + ('a, 'ac) ty -> + 'a -> + (Script.node * context) tzresult Lwt.t + + (** [unparse_items ctxt ~stack_depth unparsing_mode kty vty assoc] returns the + Micheline representation of [assoc] (being an association list) with keys + of type [kty] and values of type [vty]. Gas is being consumed from + [ctxt]. *) + val unparse_items : + context -> + stack_depth:int -> + unparsing_mode -> + 'k comparable_ty -> + ('v, 'vc) ty -> + ('k * 'v) list -> + (Script.node list * context) tzresult Lwt.t + + (** [unparse_code ctxt ~stack_depth unparsing_mode code] returns [code] + with [I_PUSH] instructions parsed and unparsed back to make sure that + only forgeable values are being pushed. The gas is being consumed from + [ctxt]. *) + val unparse_code : + context -> + stack_depth:int -> + unparsing_mode -> + Script.node -> + (Script.node * context, error trace) result Lwt.t +end diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml index 896549268d10..d7ae5ff979e3 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_accounting.ml @@ -57,7 +57,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = let* x, ctxt = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ~loc:() ctxt Script_ir_unparser.Readable @@ -124,7 +124,7 @@ let updates_of_key_values ctxt ~key_type ~value_type key_values = in let* key_node, ctxt = wrap - (Script_ir_translator.unparse_comparable_data + (Script_ir_unparser.unparse_comparable_data ~loc:Micheline.dummy_location ctxt Script_ir_unparser.Readable @@ -200,14 +200,11 @@ let setup ctxt ~key_type ~value_type entries = in let*? key_type_node, ctxt = Environment.wrap_tzresult - @@ Script_ir_translator.unparse_ty - ~loc:Micheline.dummy_location - ctxt - key_type + @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt key_type in let*? value_type_node, ctxt = Environment.wrap_tzresult - @@ Script_ir_translator.unparse_ty + @@ Script_ir_unparser.unparse_ty ~loc:Micheline.dummy_location ctxt value_type diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml index 9ff7038ac995..b5a020fb0456 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_lazy_storage_diff.ml @@ -48,7 +48,7 @@ let string_list_of_ex_token_diffs ctxt token_diffs = (Ticket_token.Ex_token {ticketer; contents_type; contents}, amount) = let* x, ctxt = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ~loc:() ctxt Script_ir_unparser.Readable diff --git a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml index 1e5072f9571d..5746fd1ee802 100644 --- a/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml +++ b/src/proto_alpha/lib_protocol/test/integration/michelson/test_ticket_operations_diff.ml @@ -121,7 +121,7 @@ let string_of_ticket_token ctxt (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let* x, _ = wrap - @@ Script_ir_translator.unparse_comparable_data + @@ Script_ir_unparser.unparse_comparable_data ctxt ~loc:() Script_ir_unparser.Readable 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 013a4b0f380c..c241cdbac26f 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 @@ -115,7 +115,7 @@ let test_context_with_nat_nat_big_map ?(sc_rollup_enable = false) () = wrap_error_lwt @@ Big_map.fresh ~temporary:false ctxt >>=? fun (ctxt, id) -> let nat_ty = Script_typed_ir.nat_t in wrap_error_lwt @@ Lwt.return - @@ Script_ir_translator.unparse_ty ~loc:() ctxt nat_ty + @@ Script_ir_unparser.unparse_ty ~loc:() ctxt nat_ty >>=? fun (nat_ty_node, ctxt) -> 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 @@ -290,7 +290,7 @@ let test_parse_comb_type () = let test_unparse_ty loc ctxt expected ty = Environment.wrap_tzresult - ( Script_ir_translator.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> + ( Script_ir_unparser.unparse_ty ~loc:() ctxt ty >>? fun (actual, ctxt) -> if actual = expected then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) @@ -331,7 +331,7 @@ let test_unparse_comparable_ty loc ctxt expected ty = let open Script_typed_ir in Environment.wrap_tzresult ( set_t (-1) ty >>? fun set_ty_ty -> - Script_ir_translator.unparse_ty ~loc:() ctxt set_ty_ty + Script_ir_unparser.unparse_ty ~loc:() ctxt set_ty_ty >>? fun (actual, ctxt) -> if actual = Prim ((), T_set, [expected], []) then ok ctxt else Alcotest.failf "Unexpected error: %s" loc ) 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 ce5313b77904..aba4549d2fb6 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 @@ -200,7 +200,7 @@ let ctxt = let unparse_comparable_ty ty = Micheline.strip_locations - (fst (assert_ok Script_ir_translator.(unparse_ty ~loc:() ctxt ty))) + (fst (assert_ok Script_ir_unparser.(unparse_ty ~loc:() ctxt ty))) let unparse_comparable_data ty x = Micheline.strip_locations diff --git a/src/proto_alpha/lib_protocol/ticket_balance_key.ml b/src/proto_alpha/lib_protocol/ticket_balance_key.ml index cc882ce36317..5251cbdb6bd2 100644 --- a/src/proto_alpha/lib_protocol/ticket_balance_key.ml +++ b/src/proto_alpha/lib_protocol/ticket_balance_key.ml @@ -35,7 +35,7 @@ open Alpha_context let of_ex_token ctxt ~owner (Ticket_token.Ex_token {ticketer; contents_type; contents}) = let loc = Micheline.dummy_location in - Script_ir_translator.unparse_ty ~loc ctxt contents_type + Script_ir_unparser.unparse_ty ~loc ctxt contents_type >>?= fun (cont_ty_unstripped, ctxt) -> (* We strip the annotations from the content type in order to map tickets with the same content type, but with different annotations, to the @@ -43,7 +43,7 @@ let of_ex_token ctxt ~owner Gas.consume ctxt (Script.strip_annotations_cost cont_ty_unstripped) >>?= fun ctxt -> let ty = Script.strip_annotations cont_ty_unstripped in - Script_ir_translator.unparse_comparable_data + Script_ir_unparser.unparse_comparable_data ~loc ctxt Script_ir_unparser.Optimized_legacy -- GitLab From 8b818a4d0766f5ea43c3626014acf227f85a579a Mon Sep 17 00:00:00 2001 From: Marcin Pastudzki Date: Fri, 22 Jul 2022 15:34:08 +0200 Subject: [PATCH 4/4] Get_contracts: Adapt to changes in proto_alpha. --- devtools/get_contracts/get_contracts_alpha.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/devtools/get_contracts/get_contracts_alpha.ml b/devtools/get_contracts/get_contracts_alpha.ml index 75ba10925c0a..bf6e08d7f092 100644 --- a/devtools/get_contracts/get_contracts_alpha.ml +++ b/devtools/get_contracts/get_contracts_alpha.ml @@ -65,7 +65,7 @@ module Proto = struct module Translator = struct type toplevel = Script_ir_translator.toplevel - type ex_ty = Script_ir_translator.ex_ty + type ex_ty = Script_typed_ir.ex_ty type ex_code = Script_ir_translator.ex_code @@ -107,11 +107,11 @@ module Proto = struct in data - let unparse_ty (ctxt : Raw_context.t) (Script_ir_translator.Ex_ty ty) = + let unparse_ty (ctxt : Raw_context.t) (Script_typed_ir.Ex_ty ty) = let open Result_syntax in let+ expr, _ = wrap_tzresult - @@ Script_ir_translator.unparse_ty ~loc:0 (Obj.magic ctxt) ty + @@ Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty in expr @@ -207,7 +207,7 @@ module Proto = struct Box.OPS.fold (fun _k v acc -> g v @ acc) Box.boxed []) @@ find_lambda_tys tv - let collect_lambda_tys (Script_ir_translator.Ex_ty ty) = + let collect_lambda_tys (Script_typed_ir.Ex_ty ty) = match find_lambda_tys ty with | [] -> None | lams -> Some (Ex_ty_lambdas (ty, lams)) @@ -222,7 +222,7 @@ module Proto = struct match parse_result with | Error _ -> acc | Ok data -> ( - match Script_ir_translator.unparse_ty ~loc:0 (Obj.magic ctxt) ty with + match Script_ir_unparser.unparse_ty ~loc:0 (Obj.magic ctxt) ty with | Error _ -> assert false | Ok (ty_expr, _) -> List.fold_left (fun acc g -> f acc ty_expr @@ g data) acc getters) -- GitLab