From f74dd5aa62f6fd56b478757447efe784454b5bef Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 14:46:00 +0200 Subject: [PATCH 1/4] Proto/Michelson: move annot types to script_ir_annot from script_typed_ir --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 2 +- src/proto_alpha/lib_protocol/dune.inc | 10 +++++----- src/proto_alpha/lib_protocol/script_ir_annot.ml | 7 ++++++- src/proto_alpha/lib_protocol/script_ir_annot.mli | 7 ++++++- .../lib_protocol/script_ir_translator.mli | 14 +++++++------- src/proto_alpha/lib_protocol/script_typed_ir.ml | 7 +------ src/proto_alpha/lib_protocol/script_typed_ir.mli | 7 +------ .../lib_protocol/script_typed_ir_size.ml | 6 +++--- 8 files changed, 30 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index f658ff5063aa..38e90299cc53 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -91,11 +91,11 @@ "Local_gas_counter", "Script_tc_errors", + "Script_ir_annot", "Script_typed_ir", "Script_typed_ir_size", "Script_typed_ir_size_costs", "Michelson_v1_gas", - "Script_ir_annot", "Script_list", "Script_comparable", "Script_set", diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index ee3cdd15b35d..3e63ce628659 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -111,11 +111,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end alpha_context.mli alpha_context.ml local_gas_counter.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -231,11 +231,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end alpha_context.mli alpha_context.ml local_gas_counter.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -351,11 +351,11 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end alpha_context.mli alpha_context.ml local_gas_counter.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml @@ -493,11 +493,11 @@ include Tezos_raw_protocol_alpha.Main Alpha_context Local_gas_counter Script_tc_errors + Script_ir_annot Script_typed_ir Script_typed_ir_size Script_typed_ir_size_costs Michelson_v1_gas - Script_ir_annot Script_list Script_comparable Script_set @@ -654,11 +654,11 @@ include Tezos_raw_protocol_alpha.Main alpha_context.mli alpha_context.ml local_gas_counter.ml script_tc_errors.ml + script_ir_annot.mli script_ir_annot.ml script_typed_ir.mli script_typed_ir.ml script_typed_ir_size.mli script_typed_ir_size.ml script_typed_ir_size_costs.mli script_typed_ir_size_costs.ml michelson_v1_gas.mli michelson_v1_gas.ml - script_ir_annot.mli script_ir_annot.ml script_list.mli script_list.ml script_comparable.mli script_comparable.ml script_set.mli script_set.ml diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 1c3436c23525..eec65f56b5ab 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -26,7 +26,12 @@ open Alpha_context open Micheline open Script_tc_errors -open Script_typed_ir + +type var_annot = Var_annot of string [@@ocaml.unboxed] + +type type_annot = Type_annot of string [@@ocaml.unboxed] + +type field_annot = Field_annot of string [@@ocaml.unboxed] let default_now_annot = Some (Var_annot "now") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 9a9008de1469..9fbdd9b52eda 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -24,7 +24,12 @@ (*****************************************************************************) open Alpha_context -open Script_typed_ir + +type var_annot = Var_annot of string [@@ocaml.unboxed] + +type type_annot = Type_annot of string [@@ocaml.unboxed] + +type field_annot = Field_annot of string [@@ocaml.unboxed] (** Default annotations *) diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.mli b/src/proto_alpha/lib_protocol/script_ir_translator.mli index 031ff5561bd1..a2f8ce6037e9 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/script_ir_translator.mli @@ -80,7 +80,7 @@ type toplevel = { arg_type : Script.node; storage_type : Script.node; views : Script_typed_ir.view Script_typed_ir.SMap.t; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; } type ('arg, 'storage) code = { @@ -93,7 +93,7 @@ type ('arg, 'storage) code = { arg_type : 'arg Script_typed_ir.ty; storage_type : 'storage Script_typed_ir.ty; views : Script_typed_ir.view Script_typed_ir.SMap.t; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; code_size : Cache_memory_helpers.sint; (** This is an over-approximation of the value size in memory, in bytes, of the contract's static part, that is its source @@ -130,7 +130,7 @@ type tc_context = | Toplevel : { storage_type : 'sto Script_typed_ir.ty; param_type : 'param Script_typed_ir.ty; - root_name : Script_typed_ir.field_annot option; + root_name : Script_ir_annot.field_annot option; } -> tc_context @@ -395,8 +395,8 @@ val parse_toplevel : context -> legacy:bool -> Script.expr -> (toplevel * context) tzresult Lwt.t val add_field_annot : - Script_typed_ir.field_annot option -> - Script_typed_ir.var_annot option -> + Script_ir_annot.field_annot option -> + Script_ir_annot.var_annot option -> ('loc, 'prim) Micheline.node -> ('loc, 'prim) Micheline.node @@ -456,7 +456,7 @@ val parse_contract_for_script : val find_entrypoint : 't Script_typed_ir.ty -> - root_name:Script_typed_ir.field_annot option -> + root_name:Script_ir_annot.field_annot option -> string -> ((Script.node -> Script.node) * ex_ty) tzresult @@ -465,7 +465,7 @@ module Entrypoints_map : Map.S with type key = string val list_entrypoints : 't Script_typed_ir.ty -> context -> - root_name:Script_typed_ir.field_annot option -> + root_name:Script_ir_annot.field_annot option -> (Michelson_v1_primitives.prim list list * (Michelson_v1_primitives.prim list * Script.unlocated_michelson_node) Entrypoints_map.t) diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.ml b/src/proto_alpha/lib_protocol/script_typed_ir.ml index 26f17381f716..ff42b060a85e 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir.ml @@ -26,6 +26,7 @@ open Alpha_context open Script_int +open Script_ir_annot (* @@ -58,12 +59,6 @@ type step_constants = { (* Preliminary definitions. *) -type var_annot = Var_annot of string [@@ocaml.unboxed] - -type type_annot = Type_annot of string [@@ocaml.unboxed] - -type field_annot = Field_annot of string [@@ocaml.unboxed] - type never = | type address = Contract.t * string diff --git a/src/proto_alpha/lib_protocol/script_typed_ir.mli b/src/proto_alpha/lib_protocol/script_typed_ir.mli index 40210da77808..382fa8b38c28 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir.mli +++ b/src/proto_alpha/lib_protocol/script_typed_ir.mli @@ -26,6 +26,7 @@ open Alpha_context open Script_int +open Script_ir_annot type step_constants = { source : Contract.t; @@ -39,12 +40,6 @@ type step_constants = { (* Preliminary definitions. *) -type var_annot = Var_annot of string [@@ocaml.unboxed] - -type type_annot = Type_annot of string [@@ocaml.unboxed] - -type field_annot = Field_annot of string [@@ocaml.unboxed] - type never = | type address = Contract.t * string diff --git a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml index 714eb18d8f2d..a45aa36fcf00 100644 --- a/src/proto_alpha/lib_protocol/script_typed_ir_size.ml +++ b/src/proto_alpha/lib_protocol/script_typed_ir_size.ml @@ -33,11 +33,11 @@ let script_string_size s = Script_string.to_string s |> string_size Micheline representation and that the strings are always shared. (One can check that they are never copied.) Besides, the following types are unboxed so that they have no tags. *) -let type_annot_size (Type_annot _) = !!0 +let type_annot_size (Script_ir_annot.Type_annot _) = !!0 -let field_annot_size (Field_annot _) = !!0 +let field_annot_size (Script_ir_annot.Field_annot _) = !!0 -let var_annot_size (Var_annot _) = !!0 +let var_annot_size (Script_ir_annot.Var_annot _) = !!0 (* Memo-sizes are 16-bit integers *) let sapling_memo_size_size = !!0 -- GitLab From 0108ff846ca9aaf4074ff36395b9754423e60ed2 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:10:13 +0200 Subject: [PATCH 2/4] Proto/Michelson: name lambda arg annot I suppose @ shouldn't have been here but changing it could break existing scripts --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 2 ++ src/proto_alpha/lib_protocol/script_ir_annot.mli | 2 ++ src/proto_alpha/lib_protocol/script_ir_translator.ml | 2 +- 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index eec65f56b5ab..2218625030c7 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -49,6 +49,8 @@ let default_self_annot = Some (Var_annot "self") let default_arg_annot = Some (Var_annot "arg") +let lambda_arg_annot = Some (Var_annot "@arg") + let default_param_annot = Some (Var_annot "parameter") let default_storage_annot = Some (Var_annot "storage") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index 9fbdd9b52eda..ee1e14d2264c 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -49,6 +49,8 @@ val default_self_annot : var_annot option val default_arg_annot : var_annot option +val lambda_arg_annot : var_annot option + val default_param_annot : var_annot option val default_storage_annot : var_annot option diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index 992d1c3fb703..2e7aa4efd3be 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -2724,7 +2724,7 @@ let[@coq_axiom_with_reason "gadt"] rec parse_data : ~stack_depth:(stack_depth + 1) ctxt ~legacy - (ta, Some (Var_annot "@arg")) + (ta, lambda_arg_annot) tr script_instr | (Lambda_t _, expr) -> -- GitLab From 285e86307af9367e36b788980bfa557a12d67e6d Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:13:49 +0200 Subject: [PATCH 3/4] Tests/proto: factorize annot construction --- .../lib_protocol/test/test_typechecking.ml | 66 ++++++++++--------- 1 file changed, 36 insertions(+), 30 deletions(-) diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index 3c043cebc776..d07f3767bc5c 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -208,6 +208,12 @@ let test_parse_ty ctxt node expected = Script_ir_translator.ty_eq ctxt (location node) actual expected >|? fun (_, ctxt) -> ctxt ) +let var_annot s = Script_ir_annot.Var_annot s + +let type_annot s = Script_ir_annot.Type_annot s + +let field_annot s = Script_ir_annot.Field_annot s + let test_parse_comb_type () = let open Script in let open Script_typed_ir in @@ -250,7 +256,7 @@ let test_parse_comb_type () = (* pair (nat %a) nat *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (nat_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> @@ -260,7 +266,7 @@ let test_parse_comb_type () = pair_t (-1) (nat_ty, None, None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim nat_prim_b) pair_nat_nat_b_ty @@ -268,8 +274,8 @@ let test_parse_comb_type () = (* pair (nat %a) (nat %b) *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_parse_ty ctxt (pair_prim2 nat_prim_a nat_prim_b) pair_nat_a_nat_b_ty @@ -277,13 +283,13 @@ let test_parse_comb_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_t (-1) - (nat_ty, Some (Field_annot "b"), None) - (nat_ty, Some (Field_annot "c"), None) + (nat_ty, Some (field_annot "b"), None) + (nat_ty, Some (field_annot "c"), None) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (pair_nat_b_nat_c_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -297,8 +303,8 @@ let test_parse_comb_type () = >>??= fun pair_b_nat_nat_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (pair_b_nat_nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (pair_b_nat_nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_parse_ty @@ -351,7 +357,7 @@ let test_unparse_comb_type () = (* pair (nat %a) nat *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (nat_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> @@ -365,7 +371,7 @@ let test_unparse_comb_type () = pair_t (-1) (nat_ty, None, None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_unparse_ty @@ -377,8 +383,8 @@ let test_unparse_comb_type () = (* pair (nat %a) (nat %b) *) pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_unparse_ty @@ -390,13 +396,13 @@ let test_unparse_comb_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_t (-1) - (nat_ty, Some (Field_annot "b"), None) - (nat_ty, Some (Field_annot "c"), None) + (nat_ty, Some (field_annot "b"), None) + (nat_ty, Some (field_annot "c"), None) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) + (nat_ty, Some (field_annot "a"), None) (pair_nat_b_nat_c_ty, None, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -411,8 +417,8 @@ let test_unparse_comb_type () = >>??= fun pair_nat_nat_ty -> pair_t (-1) - (nat_ty, Some (Field_annot "a"), None) - (pair_nat_nat_ty, Some (Field_annot "b"), None) + (nat_ty, Some (field_annot "a"), None) + (pair_nat_nat_ty, Some (field_annot "b"), None) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_ty @@ -425,7 +431,7 @@ let test_unparse_comb_type () = pair_t (-1) (nat_ty, None, None) - (pair_nat_nat_ty, None, Some (Var_annot "b")) + (pair_nat_nat_ty, None, Some (var_annot "b")) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> test_unparse_ty @@ -439,7 +445,7 @@ let test_unparse_comb_type () = (-1) (nat_ty, None, None) (nat_ty, None, None) - ~annot:(Some (Type_annot "b")) + ~annot:(Some (type_annot "b")) >>??= fun pair_b_nat_nat_ty -> pair_t (-1) (nat_ty, None, None) (pair_b_nat_nat_ty, None, None) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> @@ -495,7 +501,7 @@ let test_unparse_comb_comparable_type () = pair_nat_nat_nat_ty >>?= fun ctxt -> (* pair (nat %a) nat *) - pair_key (-1) (nat_ty, Some (Field_annot "a")) (nat_ty, None) ~annot:None + pair_key (-1) (nat_ty, Some (field_annot "a")) (nat_ty, None) ~annot:None >>??= fun pair_nat_a_nat_ty -> test_unparse_comparable_ty __LOC__ @@ -504,7 +510,7 @@ let test_unparse_comb_comparable_type () = pair_nat_a_nat_ty >>?= fun ctxt -> (* pair nat (nat %b) *) - pair_key (-1) (nat_ty, None) (nat_ty, Some (Field_annot "b")) ~annot:None + pair_key (-1) (nat_ty, None) (nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_nat_b_ty -> test_unparse_comparable_ty __LOC__ @@ -515,8 +521,8 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (nat %b) *) pair_key (-1) - (nat_ty, Some (Field_annot "a")) - (nat_ty, Some (Field_annot "b")) + (nat_ty, Some (field_annot "a")) + (nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_a_nat_b_ty -> test_unparse_comparable_ty @@ -528,13 +534,13 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (nat %b) (nat %c) *) pair_key (-1) - (nat_ty, Some (Field_annot "b")) - (nat_ty, Some (Field_annot "c")) + (nat_ty, Some (field_annot "b")) + (nat_ty, Some (field_annot "c")) ~annot:None >>??= fun pair_nat_b_nat_c_ty -> pair_key (-1) - (nat_ty, Some (Field_annot "a")) + (nat_ty, Some (field_annot "a")) (pair_nat_b_nat_c_ty, None) ~annot:None >>??= fun pair_nat_a_nat_b_nat_c_ty -> @@ -547,8 +553,8 @@ let test_unparse_comb_comparable_type () = (* pair (nat %a) (pair %b nat nat) *) pair_key (-1) - (nat_ty, Some (Field_annot "a")) - (pair_nat_nat_ty, Some (Field_annot "b")) + (nat_ty, Some (field_annot "a")) + (pair_nat_nat_ty, Some (field_annot "b")) ~annot:None >>??= fun pair_nat_a_pair_b_nat_nat_ty -> test_unparse_comparable_ty @@ -558,7 +564,7 @@ let test_unparse_comb_comparable_type () = pair_nat_a_pair_b_nat_nat_ty >>?= fun ctxt -> (* pair nat (pair :b nat nat) *) - pair_key (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (Type_annot "b")) + pair_key (-1) (nat_ty, None) (nat_ty, None) ~annot:(Some (type_annot "b")) >>??= fun pair_b_nat_nat_ty -> pair_key (-1) (nat_ty, None) (pair_b_nat_nat_ty, None) ~annot:None >>??= fun pair_nat_pair_b_nat_nat_ty -> -- GitLab From e2f6f29e5c78e5c4b13ab32bc0f4803735704457 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 18 Oct 2021 15:14:33 +0200 Subject: [PATCH 4/4] Proto/Michelson: make annot types private --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 8 ++++++++ src/proto_alpha/lib_protocol/script_ir_annot.mli | 14 +++++++++++--- .../lib_protocol/test/test_typechecking.ml | 6 +++--- 3 files changed, 22 insertions(+), 6 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 2218625030c7..9b1f60dbe404 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -33,6 +33,14 @@ type type_annot = Type_annot of string [@@ocaml.unboxed] type field_annot = Field_annot of string [@@ocaml.unboxed] +module FOR_TESTS = struct + let unsafe_var_annot_of_string s = Var_annot s + + let unsafe_type_annot_of_string s = Type_annot s + + let unsafe_field_annot_of_string s = Field_annot s +end + let default_now_annot = Some (Var_annot "now") let default_amount_annot = Some (Var_annot "amount") diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index ee1e14d2264c..d8b4f660fe76 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -25,11 +25,19 @@ open Alpha_context -type var_annot = Var_annot of string [@@ocaml.unboxed] +type var_annot = private Var_annot of string [@@ocaml.unboxed] -type type_annot = Type_annot of string [@@ocaml.unboxed] +type type_annot = private Type_annot of string [@@ocaml.unboxed] -type field_annot = Field_annot of string [@@ocaml.unboxed] +type field_annot = private Field_annot of string [@@ocaml.unboxed] + +module FOR_TESTS : sig + val unsafe_var_annot_of_string : string -> var_annot + + val unsafe_type_annot_of_string : string -> type_annot + + val unsafe_field_annot_of_string : string -> field_annot +end (** Default annotations *) diff --git a/src/proto_alpha/lib_protocol/test/test_typechecking.ml b/src/proto_alpha/lib_protocol/test/test_typechecking.ml index d07f3767bc5c..57848a7e8ada 100644 --- a/src/proto_alpha/lib_protocol/test/test_typechecking.ml +++ b/src/proto_alpha/lib_protocol/test/test_typechecking.ml @@ -208,11 +208,11 @@ let test_parse_ty ctxt node expected = Script_ir_translator.ty_eq ctxt (location node) actual expected >|? fun (_, ctxt) -> ctxt ) -let var_annot s = Script_ir_annot.Var_annot s +let var_annot = Script_ir_annot.FOR_TESTS.unsafe_var_annot_of_string -let type_annot s = Script_ir_annot.Type_annot s +let type_annot = Script_ir_annot.FOR_TESTS.unsafe_type_annot_of_string -let field_annot s = Script_ir_annot.Field_annot s +let field_annot = Script_ir_annot.FOR_TESTS.unsafe_field_annot_of_string let test_parse_comb_type () = let open Script in -- GitLab