From 64e6c4668334a65c4f3a9c1e61e0604300037b36 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 9 Oct 2025 16:41:45 +0200 Subject: [PATCH 1/2] Proto: Typed_IR: views in AST only for Lambda implementation --- src/proto_alpha/lib_plugin/RPC.ml | 2 - src/proto_alpha/lib_protocol/apply.ml | 42 +++- .../lib_protocol/michelson_v1_gas.ml | 8 + .../lib_protocol/michelson_v1_gas.mli | 6 + .../lib_protocol/script_interpreter.ml | 213 ++++++++++++------ .../lib_protocol/script_ir_translator.ml | 9 +- .../lib_protocol/script_ir_translator.mli | 2 +- src/proto_alpha/lib_protocol/script_native.ml | 5 + .../lib_protocol/script_native.mli | 4 + .../lib_protocol/script_native_types.ml | 20 ++ .../lib_protocol/script_native_types.mli | 20 ++ src/proto_alpha/lib_protocol/script_typed.ml | 2 +- src/proto_alpha/lib_protocol/script_typed.mli | 2 +- .../michelson/test_ticket_accounting.ml | 1 - .../michelson/test_ticket_operations_diff.ml | 1 - 15 files changed, 240 insertions(+), 97 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index 09b5c218bbfd..fda15924c4fb 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1616,7 +1616,6 @@ module Scripts = struct implementation; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -1639,7 +1638,6 @@ module Scripts = struct implementation; arg_type; storage_type; - views; entrypoints; code_size; storage; diff --git a/src/proto_alpha/lib_protocol/apply.ml b/src/proto_alpha/lib_protocol/apply.ml index b412a56dcbc7..9b9731d384e6 100644 --- a/src/proto_alpha/lib_protocol/apply.ml +++ b/src/proto_alpha/lib_protocol/apply.ml @@ -49,6 +49,7 @@ type error += | Stake_modification_with_no_delegate_set | Invalid_nonzero_transaction_amount of Tez.t | Invalid_staking_parameters_sender + | Cannot_originate_native_contract let () = let description = @@ -284,7 +285,15 @@ let () = ~pp:(fun ppf () -> Format.fprintf ppf "Invalid staking parameters sender") Data_encoding.empty (function Invalid_staking_parameters_sender -> Some () | _ -> None) - (fun () -> Invalid_staking_parameters_sender) + (fun () -> Invalid_staking_parameters_sender) ; + register_error_kind + `Permanent + ~id:"operations.cannot_originate_native_contract" + ~title:"Cannot originate native contract" + ~description:"A native contract cannot be originated." + Data_encoding.empty + (function Cannot_originate_native_contract -> Some () | _ -> None) + (fun () -> Cannot_originate_native_contract) open Apply_results open Apply_operation_result @@ -1348,18 +1357,27 @@ let apply_manager_operation : type kind. ~allow_forged_lazy_storage_id_in_storage:false (Script script) in - let (Script {storage_type; views; storage; _}) = parsed_script in - let views_result = - Script_ir_translator.parse_views - ctxt - ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) - storage_type - views + let (Script {storage_type; storage; implementation; _}) = + parsed_script in - let* _typed_views, ctxt = - trace - (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) - views_result + let* ctxt = + match implementation with + | Lambda {views; _} -> + let views_result = + Script_ir_translator.parse_views + ctxt + ~elab_conf:Script_ir_translator_config.(make ~legacy:false ()) + storage_type + views + in + let* _typed_views, ctxt = + trace + (Script_tc_errors.Ill_typed_contract (unparsed_code, [])) + views_result + in + return ctxt + (* Native branch is technically dead, a native contract cannot be originated *) + | Native _ -> tzfail Cannot_originate_native_contract in let+ ctxt, origination_result, ops = apply_origination diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml index 5ad8fb2b54bd..c72a60d81e97 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.ml @@ -630,9 +630,17 @@ module Cost_of = struct let view_get (elt : Script_string.t) (m : Script_typed_ir.view_map) = map_get elt m + let native_view_get (elt : Script_string.t) + (m : 'storage Script_native_types.view_map) = + map_get elt m + let view_update (elt : Script_string.t) (m : Script_typed_ir.view_map) = map_update elt m + let native_view_update (elt : Script_string.t) + (m : 'storage Script_native_types.view_map) = + map_update elt m + let join_tickets : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ticket -> diff --git a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli index 7fc1008106b5..8fe328f1e519 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_gas.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_gas.mli @@ -349,8 +349,14 @@ module Cost_of : sig val view_get : Script_string.t -> Script_typed_ir.view_map -> Gas.cost + val native_view_get : + Script_string.t -> 'storage Script_native_types.view_map -> Gas.cost + val view_update : Script_string.t -> Script_typed_ir.view_map -> Gas.cost + val native_view_update : + Script_string.t -> 'storage Script_native_types.view_map -> Gas.cost + val transfer_tokens : Gas.cost val implicit_account : Gas.cost diff --git a/src/proto_alpha/lib_protocol/script_interpreter.ml b/src/proto_alpha/lib_protocol/script_interpreter.ml index 182af698fae3..a93b89f5cccd 100644 --- a/src/proto_alpha/lib_protocol/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/script_interpreter.ml @@ -571,7 +571,9 @@ module Raw = struct match script_opt with | None -> (return_none [@ocaml.tailcall]) ctxt | Some script -> ( - let* Ex_script (Script {storage; storage_type; views; _}), ctxt = + let* ( Ex_script + (Script {storage; storage_type; implementation; _}), + ctxt ) = parse_script ~elab_conf:legacy ~allow_forged_tickets_in_storage:true @@ -579,80 +581,151 @@ module Raw = struct ctxt script in - let*? ctxt = - Gas.consume ctxt (Interp_costs.view_get name views) - in - match Script_map.get name views with - | None -> (return_none [@ocaml.tailcall]) ctxt - | Some view -> ( - let view_result = - Script_ir_translator.parse_view - ctxt - ~elab_conf:legacy - storage_type - view - in - let* ( Typed_view - { - input_ty = input_ty'; - output_ty = output_ty'; - kinstr; - original_code_expr = _; - }, - ctxt ) = - trace_eval - (fun () -> - Script_tc_errors.Ill_typed_contract - (Micheline.strip_locations view.view_code, [])) - view_result - in - let io_ty = - let open Gas_monad.Syntax in - let* out_eq = - ty_eq ~error_details:Fast output_ty' output_ty - in - let+ in_eq = ty_eq ~error_details:Fast input_ty input_ty' in - (out_eq, in_eq) + match implementation with + | Native {kind} -> ( + let*? views = Script_native.get_views kind in + let*? ctxt = + Gas.consume ctxt (Interp_costs.native_view_get name views) in - let*? eq, ctxt = Gas_monad.run ctxt io_ty in - match eq with - | Error Inconsistent_types_fast -> - (return_none [@ocaml.tailcall]) ctxt - | Ok (Eq, Eq) -> - let kcons = - KCons (ICons_some (kinstr_location k, k), ks) + match Script_map.get name views with + | None -> (return_none [@ocaml.tailcall]) ctxt + | Some + (Ex_view + { + name = _; + ty = + { + input_ty = Ty_ex_c input_ty'; + output_ty = Ty_ex_c output_ty'; + }; + implementation; + }) -> ( + let io_ty = + let open Gas_monad.Syntax in + let* out_eq = + ty_eq ~error_details:Fast output_ty' output_ty + in + let+ in_eq = + ty_eq ~error_details:Fast input_ty input_ty' + in + (out_eq, in_eq) in - let* ctxt, balance = - Contract.get_balance_carbonated ctxt c + let*? eq, ctxt = Gas_monad.run ctxt io_ty in + match eq with + | Error Inconsistent_types_fast -> + (return_none [@ocaml.tailcall]) ctxt + | Ok (Eq, Eq) -> + let* ctxt, balance = + Contract.get_balance_carbonated ctxt c + in + let step_constants = + { + sender = + Destination.Contract + (Contract.Originated sc.self); + self = contract_hash; + amount = Tez.zero; + balance; + (* The following remain unchanged, but let's + list them anyway, so that we don't forget + to update something added later. *) + payer = sc.payer; + chain_id = sc.chain_id; + now = sc.now; + level = sc.level; + } + in + let* result, ctxt = + implementation (ctxt, step_constants) input storage + in + let gas, ctxt = + local_gas_counter_and_outdated_context ctxt + in + (step [@ocaml.tailcall]) + (ctxt, sc) + gas + (ICons_some (kinstr_location k, k)) + ks + result + stack)) + | Lambda {views; _} -> ( + let*? ctxt = + Gas.consume ctxt (Interp_costs.view_get name views) + in + match Script_map.get name views with + | None -> (return_none [@ocaml.tailcall]) ctxt + | Some view -> ( + let view_result = + Script_ir_translator.parse_view + ctxt + ~elab_conf:legacy + storage_type + view in - let gas, ctxt = - local_gas_counter_and_outdated_context ctxt + let* ( Typed_view + { + input_ty = input_ty'; + output_ty = output_ty'; + kinstr; + original_code_expr = _; + }, + ctxt ) = + trace_eval + (fun () -> + Script_tc_errors.Ill_typed_contract + (Micheline.strip_locations view.view_code, [])) + view_result in - let sty = - Option.map (fun t -> Item_t (output_ty, t)) stack_ty + let io_ty = + let open Gas_monad.Syntax in + let* out_eq = + ty_eq ~error_details:Fast output_ty' output_ty + in + let+ in_eq = + ty_eq ~error_details:Fast input_ty input_ty' + in + (out_eq, in_eq) in - (step [@ocaml.tailcall]) - ( ctxt, - { - sender = - Destination.Contract (Contract.Originated sc.self); - self = contract_hash; - amount = Tez.zero; - balance; - (* The following remain unchanged, but let's + let*? eq, ctxt = Gas_monad.run ctxt io_ty in + match eq with + | Error Inconsistent_types_fast -> + (return_none [@ocaml.tailcall]) ctxt + | Ok (Eq, Eq) -> + let kcons = + KCons (ICons_some (kinstr_location k, k), ks) + in + let* ctxt, balance = + Contract.get_balance_carbonated ctxt c + in + let gas, ctxt = + local_gas_counter_and_outdated_context ctxt + in + let sty = + Option.map (fun t -> Item_t (output_ty, t)) stack_ty + in + (step [@ocaml.tailcall]) + ( ctxt, + { + sender = + Destination.Contract + (Contract.Originated sc.self); + self = contract_hash; + amount = Tez.zero; + balance; + (* The following remain unchanged, but let's list them anyway, so that we don't forget to update something added later. *) - payer = sc.payer; - chain_id = sc.chain_id; - now = sc.now; - level = sc.level; - } ) - gas - kinstr - (instrument - @@ KView_exit (sc, KReturn (stack, sty, kcons))) - (input, storage) - (EmptyCell, EmptyCell)))) + payer = sc.payer; + chain_id = sc.chain_id; + now = sc.now; + level = sc.level; + } ) + gas + kinstr + (instrument + @@ KView_exit (sc, KReturn (stack, sty, kcons))) + (input, storage) + (EmptyCell, EmptyCell))))) and step : type a s b t r f. (a, s, b, t, r, f) step_type = let open Lwt_result_syntax in @@ -1835,7 +1908,6 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage = old_storage; storage_type; entrypoints; - views; }), ctxt ) = match cached_script with @@ -1874,7 +1946,7 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal in let* (ops, new_storage), ctxt = match implementation with - | Lambda {code} -> + | Lambda {code; _} -> trace (Runtime_contract_error step_constants.self) (interp logger (ctxt, step_constants) code (arg, old_storage)) @@ -1918,7 +1990,6 @@ let execute_any_arg logger ctxt mode step_constants ~entrypoint ~internal storage; storage_type; entrypoints; - views; }) in let*? arg_type_has_tickets, ctxt = diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 1fb6a4017652..9185e117f4d0 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1128,6 +1128,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -1140,7 +1141,6 @@ type ('arg, 'storage) code = implementation : ('arg, 'storage) implementation; arg_type : ('arg, _) ty; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; } @@ -5177,7 +5177,6 @@ let get_typed_native_code : arg_type; storage_type; entrypoints; - views = Script_map.empty string_t; code_size = Saturation_repr.zero; }), ctxt ) @@ -5242,10 +5241,9 @@ let parse_code : ( Ex_code (Code { - implementation = Lambda {code}; + implementation = Lambda {code; views}; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -5311,7 +5309,6 @@ let parse_script : implementation; arg_type; storage_type; - views; entrypoints; code_size; }), @@ -5343,7 +5340,6 @@ let parse_script : arg_type; storage; storage_type; - views; entrypoints; }), ctxt ) @@ -6189,7 +6185,6 @@ let script_size storage; storage_type; entrypoints = _; - views = _; })) = let nodes, storage_size = Script_typed_ir_size.value_size storage_type storage diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index dfa9e0a04e3d..ab081d51c278 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -95,6 +95,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -107,7 +108,6 @@ type ('arg, 'storage) code = implementation : ('arg, 'storage) implementation; arg_type : ('arg, _) Script_typed_ir.ty; storage_type : ('storage, _) Script_typed_ir.ty; - views : Script_typed_ir.view_map; entrypoints : 'arg Script_typed_ir.entrypoints; code_size : Cache_memory_helpers.sint; (** This is an over-approximation of the value size in memory, in diff --git a/src/proto_alpha/lib_protocol/script_native.ml b/src/proto_alpha/lib_protocol/script_native.ml index cb8d86006c4d..2c32484e1e69 100644 --- a/src/proto_alpha/lib_protocol/script_native.ml +++ b/src/proto_alpha/lib_protocol/script_native.ml @@ -116,6 +116,11 @@ module CLST_contract = struct execute_withdraw (ctxt, step_constants) amount storage end +let get_views : type arg storage. + (arg, storage) kind -> storage Script_native_types.view_map tzresult = + function + | CLST_kind -> assert false + let execute (type arg storage) (ctxt, step_constants) (kind : (arg, storage) kind) (arg : arg) (storage : storage) : ((operation Script_list.t, storage) pair * context, error trace) result diff --git a/src/proto_alpha/lib_protocol/script_native.mli b/src/proto_alpha/lib_protocol/script_native.mli index bee2e761571e..21af8053fd8c 100644 --- a/src/proto_alpha/lib_protocol/script_native.mli +++ b/src/proto_alpha/lib_protocol/script_native.mli @@ -18,6 +18,10 @@ module CLST_contract : sig | Amount_too_large of Destination.t * CLST_types.nat end +val get_views : + 'arg 'storage. + ('arg, 'storage) kind -> (Script_string.t, 'storage ex_view) map tzresult + (* [execute ctxt kind arg storage] executes the given native contract [kind] with [arg] and [storage], and returns the list of operations, the new storage and the context. *) diff --git a/src/proto_alpha/lib_protocol/script_native_types.ml b/src/proto_alpha/lib_protocol/script_native_types.ml index b1ef9ed15ee1..6451f6618816 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.ml +++ b/src/proto_alpha/lib_protocol/script_native_types.ml @@ -106,6 +106,26 @@ module Helpers = struct (ty, {root = entrypoint; original_type_expr = ty.untyped}) end +type ('arg, 'output) view_type = { + input_ty : 'arg ty_ex_c; + output_ty : 'output ty_ex_c; +} + +type ('arg, 'storage, 'output) view = { + name : Script_string.t; + ty : ('arg, 'output) view_type; + implementation : + context * step_constants -> + 'arg -> + 'storage -> + ('output * context) tzresult Lwt.t; +} + +type 'storage ex_view = + | Ex_view : ('arg, 'storage, 'output) view -> 'storage ex_view + +type 'storage view_map = (Script_string.t, 'storage ex_view) map + module CLST_types = struct open Helpers diff --git a/src/proto_alpha/lib_protocol/script_native_types.mli b/src/proto_alpha/lib_protocol/script_native_types.mli index 02c7161a625d..459ffe9ebb09 100644 --- a/src/proto_alpha/lib_protocol/script_native_types.mli +++ b/src/proto_alpha/lib_protocol/script_native_types.mli @@ -10,6 +10,11 @@ open Alpha_context open Script_typed_ir +type ('arg, 'output) view_type = { + input_ty : 'arg ty_ex_c; + output_ty : 'output ty_ex_c; +} + (** Types declaration of CLST contracts (entrypoints and storage). *) module CLST_types : sig type nat = Script_int.n Script_int.num @@ -39,6 +44,21 @@ type ex_kind_and_types = val get_typed_kind_and_types : Script_native_repr.t -> ex_kind_and_types tzresult +type ('arg, 'storage, 'output) view = { + name : Script_string.t; + ty : ('arg, 'output) view_type; + implementation : + context * step_constants -> + 'arg -> + 'storage -> + ('output * context) tzresult Lwt.t; +} + +type 'storage ex_view = + | Ex_view : ('arg, 'storage, 'output) view -> 'storage ex_view + +type 'storage view_map = (Script_string.t, 'storage ex_view) map + module Internal_for_tests : sig val eq_native_kind : ('arg, 'storage) kind -> ('arg', 'storage') kind -> bool diff --git a/src/proto_alpha/lib_protocol/script_typed.ml b/src/proto_alpha/lib_protocol/script_typed.ml index e69a13d518cf..62f5e28da12a 100644 --- a/src/proto_alpha/lib_protocol/script_typed.ml +++ b/src/proto_alpha/lib_protocol/script_typed.ml @@ -13,6 +13,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -26,7 +27,6 @@ type ('arg, 'storage) script = arg_type : ('arg, _) ty; storage : 'storage; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; } diff --git a/src/proto_alpha/lib_protocol/script_typed.mli b/src/proto_alpha/lib_protocol/script_typed.mli index cdc34b34eb76..326d602e3f2d 100644 --- a/src/proto_alpha/lib_protocol/script_typed.mli +++ b/src/proto_alpha/lib_protocol/script_typed.mli @@ -13,6 +13,7 @@ type ('arg, 'storage) implementation = | Lambda : { code : (('arg, 'storage) pair, (operation Script_list.t, 'storage) pair) lambda; + views : view_map; } -> ('arg, 'storage) implementation | Native : { @@ -26,7 +27,6 @@ type ('arg, 'storage) script = arg_type : ('arg, _) ty; storage : 'storage; storage_type : ('storage, _) ty; - views : view_map; entrypoints : 'arg entrypoints; code_size : Cache_memory_helpers.sint; (* This is an over-approximation of the value size in memory, in 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 4ff2e24731ae..bf90cb7bd415 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 @@ -346,7 +346,6 @@ let origination_operation ctxt ~sender ~script:(code, storage) ~orig_contract = storage; implementation = _; arg_type = _; - views = _; entrypoints = _; code_size = _; }), 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 d0e664c3e618..13ad856324d5 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 @@ -272,7 +272,6 @@ let origination_operation block ~sender ~baker ~script ~storage ~forges_tickets storage; implementation = _; arg_type = _; - views = _; entrypoints = _; code_size = _; }), -- GitLab From e53948fb6228c40edfc5757b9c6b784791c44be7 Mon Sep 17 00:00:00 2001 From: Pierrick Couderc Date: Thu, 9 Oct 2025 16:43:20 +0200 Subject: [PATCH 2/2] Plugin: make view RPC working with native contracts --- src/proto_alpha/lib_plugin/RPC.ml | 88 +++++++++++++++++++++---------- 1 file changed, 61 insertions(+), 27 deletions(-) diff --git a/src/proto_alpha/lib_plugin/RPC.ml b/src/proto_alpha/lib_plugin/RPC.ml index fda15924c4fb..067ab1fad48a 100644 --- a/src/proto_alpha/lib_plugin/RPC.ml +++ b/src/proto_alpha/lib_plugin/RPC.ml @@ -1211,14 +1211,8 @@ module Scripts = struct ~now_opt ~level_opt in - let script_entrypoint_type ctxt expr entrypoint = - let ctxt = Gas.set_unlimited ctxt in - let legacy = false in + let entrypoint_type ctxt arg_type entrypoint entrypoints = let open Script_ir_translator in - let* {arg_type; _}, ctxt = parse_toplevel ctxt expr in - let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = - parse_parameter_ty_and_entrypoints ctxt ~legacy arg_type - in let*? r, _ctxt = Gas_monad.run ctxt @@ Script_ir_translator.find_entrypoint @@ -1230,6 +1224,24 @@ module Scripts = struct let*? (Ex_ty_cstr {original_type_expr; _}) = r in return @@ Micheline.strip_locations original_type_expr in + let script_entrypoint_type ctxt expr entrypoint = + let open Script_ir_translator in + let ctxt = Gas.set_unlimited ctxt in + let* {arg_type; _}, ctxt = + Script_ir_translator.parse_toplevel ctxt expr + in + let*? Ex_parameter_ty_and_entrypoints {arg_type; entrypoints}, _ = + parse_parameter_ty_and_entrypoints ctxt ~legacy:false arg_type + in + entrypoint_type ctxt arg_type entrypoint entrypoints + in + let native_entrypoint_type ctxt native entrypoint = + let ctxt = Gas.set_unlimited ctxt in + let*? (Ex_kind_and_types (_, {arg_type; entrypoints; _})) = + Script_native_types.get_typed_kind_and_types native + in + entrypoint_type ctxt arg_type entrypoint entrypoints + in let script_view_type ctxt contract expr view = let ctxt = Gas.set_unlimited ctxt in let open Script_ir_translator in @@ -1242,6 +1254,36 @@ module Scripts = struct | Some Script_typed_ir.{input_ty; output_ty; _} -> return (input_ty, output_ty) in + let native_view_type ctxt contract kind view = + let*? (Ex_kind_and_types (kind, _)) = + Script_native_types.get_typed_kind_and_types kind + in + let*? views = Script_native.get_views kind in + let*? view_name = Script_string.of_string view in + match Script_map.get view_name views with + | None -> + Environment.Error_monad.tzfail + (View_helpers.View_not_found (contract, view)) + | Some + (Script_native_types.Ex_view + { + ty = {input_ty = Ty_ex_c input_ty; output_ty = Ty_ex_c output_ty}; + _; + }) -> + let*? unparsed_input_ty, _ctxt = + Script_ir_unparser.unparse_ty + ~loc:Micheline.dummy_location + ctxt + input_ty + in + let*? unparsed_output_ty, _ctxt = + Script_ir_unparser.unparse_ty + ~loc:Micheline.dummy_location + ctxt + output_ty + in + return (unparsed_input_ty, unparsed_output_ty) + in Registration.register0 ~chunked:true S.run_code @@ -1412,17 +1454,13 @@ module Scripts = struct View_helpers.Viewed_contract_has_no_script) script_opt in - (* The native case will be handled in a later MR (!19583). *) - let script = + let* view_ty = match script with - | Script.Script s -> s - | Native _ -> - Stdlib.failwith - "Tzip4 views are not implemented yet for native contracts" + | Script.Native n -> native_entrypoint_type ctxt n.kind entrypoint + | Script.Script s -> + let*? decoded_script = Script_repr.(force_decode s.code) in + script_entrypoint_type ctxt decoded_script entrypoint in - (* let*? script = Environment.Error_monad.Result_syntax wrap_tzresult script in *) - let*? decoded_script = Script_repr.(force_decode script.code) in - let* view_ty = script_entrypoint_type ctxt decoded_script entrypoint in let*? ty = View_helpers.extract_view_output_type entrypoint view_ty in let contract = Contract.Originated contract_hash in let* balance = Contract.get_balance ctxt contract in @@ -1471,7 +1509,7 @@ module Scripts = struct ctxt unparsing_mode step_constants - ~script:(Script.Script script) + ~script ~cached_script:None ~entrypoint ~parameter @@ -1511,19 +1549,15 @@ module Scripts = struct ~none:(Error_monad.error View_helpers.Viewed_contract_has_no_script) script_opt in - (* The native case will be handled in a later MR (!19583). *) - let script = + let* input_ty, output_ty = match script with - | Script.Script s -> s - | Script.Native _ -> - Stdlib.failwith - "Views are not implemented yet for native contracts" + | Script.Native {kind; _} -> + native_view_type ctxt contract_hash kind view + | Script.Script {code; _} -> + let*? decoded_script = Script_repr.(force_decode code) in + script_view_type ctxt contract_hash decoded_script view in - let*? decoded_script = Script_repr.(force_decode script.code) in let contract = Contract.Originated contract_hash in - let* input_ty, output_ty = - script_view_type ctxt contract_hash decoded_script view - in let* balance = Contract.get_balance ctxt contract in let ctxt, step_constants = compute_step_constants -- GitLab