diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 38e90299cc53996e58f3685e7a1a38ffdf1254e3..1a58a2a875f1edbe9c262f5701447d2109f5293e 100644 --- a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL @@ -3,6 +3,7 @@ "hash": "ProtoALphaALphaALphaALphaALphaALphaALphaALphaDdp3zK", "modules": [ "Misc", + "Non_empty_string", "Path_encoding", "Storage_description", "State_hash", diff --git a/src/proto_alpha/lib_protocol/dune.inc b/src/proto_alpha/lib_protocol/dune.inc index 3e63ce628659b6b32e6cc86128f98dd23104b278..8065285538ddc3cf971a77e3ca26a8340fd91fa5 100644 --- a/src/proto_alpha/lib_protocol/dune.inc +++ b/src/proto_alpha/lib_protocol/dune.inc @@ -29,6 +29,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (targets registerer.ml) (deps misc.mli misc.ml + non_empty_string.mli non_empty_string.ml path_encoding.mli path_encoding.ml storage_description.mli storage_description.ml state_hash.mli state_hash.ml @@ -149,6 +150,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (targets functor.ml) (deps misc.mli misc.ml + non_empty_string.mli non_empty_string.ml path_encoding.mli path_encoding.ml storage_description.mli storage_description.ml state_hash.mli state_hash.ml @@ -269,6 +271,7 @@ module CamlinternalFormatBasics = struct include CamlinternalFormatBasics end (targets protocol.ml) (deps misc.mli misc.ml + non_empty_string.mli non_empty_string.ml path_encoding.mli path_encoding.ml storage_description.mli storage_description.ml state_hash.mli state_hash.ml @@ -411,6 +414,7 @@ include Tezos_raw_protocol_alpha.Main -open Error_monad)) (modules Misc + Non_empty_string Path_encoding Storage_description State_hash @@ -572,6 +576,7 @@ include Tezos_raw_protocol_alpha.Main (alias runtest_compile_protocol) (deps misc.mli misc.ml + non_empty_string.mli non_empty_string.ml path_encoding.mli path_encoding.ml storage_description.mli storage_description.ml state_hash.mli state_hash.ml diff --git a/src/proto_alpha/lib_protocol/non_empty_string.ml b/src/proto_alpha/lib_protocol/non_empty_string.ml new file mode 100644 index 0000000000000000000000000000000000000000..9ce9b11d27e8e67b24e61e5491f657841f6664cb --- /dev/null +++ b/src/proto_alpha/lib_protocol/non_empty_string.ml @@ -0,0 +1,42 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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. *) +(* *) +(*****************************************************************************) + +include Compare.String + +let of_string = function "" -> None | s -> Some s + +let of_string_exn = function + | "" -> invalid_arg "Unexpected empty string" + | s -> s + +let cat2 a ?(sep = "") b = String.concat sep [a; b] + +let split_on_last sep s = + match String.rindex_opt s sep with + | Some i when Compare.Int.(i > 0 && i < String.length s - 1) -> + let s1 = String.sub s 0 i in + let s2 = String.sub s (i + 1) (String.length s - 1 - i) in + Some (s1, s2) + | _ -> None diff --git a/src/proto_alpha/lib_protocol/non_empty_string.mli b/src/proto_alpha/lib_protocol/non_empty_string.mli new file mode 100644 index 0000000000000000000000000000000000000000..a9973efd775f58b654370566cf84b4eff74d2505 --- /dev/null +++ b/src/proto_alpha/lib_protocol/non_empty_string.mli @@ -0,0 +1,45 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2021 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. *) +(* *) +(*****************************************************************************) + +(** A string that is guaranteed to be non-empty *) +type t = private string + +include Compare.S with type t := t + +(** Returns [None] if the original string is empty. *) +val of_string : string -> t option + +(** Fails with [Invalid_argument] if the original string is empty. *) +val of_string_exn : string -> t + +(** [cat2 a b] concatenates [a] and [b]. + [cat2 a ~sep b] concatenates [a], [sep], and [b]. *) +val cat2 : t -> ?sep:string -> t -> t + +(** [split_on_last c s] finds the last occurrence of [c] in [s] and returns + the substring before and the substring after. + Returns [None] if [c] is not present in [s] or if one or both substrings + would end up being empty. *) +val split_on_last : char -> t -> (t * t) option diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 9b1f60dbe4040e447d0fb3e40a6864849f61a3c9..90ac3451266ab44f561171baf5e1b23389e17ee5 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -27,85 +27,95 @@ open Alpha_context open Micheline open Script_tc_errors -type var_annot = Var_annot of string [@@ocaml.unboxed] +type var_annot = Var_annot of Non_empty_string.t [@@ocaml.unboxed] -type type_annot = Type_annot of string [@@ocaml.unboxed] +type type_annot = Type_annot of Non_empty_string.t [@@ocaml.unboxed] -type field_annot = Field_annot of string [@@ocaml.unboxed] +type field_annot = Field_annot of Non_empty_string.t [@@ocaml.unboxed] module FOR_TESTS = struct - let unsafe_var_annot_of_string s = Var_annot s + let unsafe_var_annot_of_string s = + Var_annot (Non_empty_string.of_string_exn s) - let unsafe_type_annot_of_string s = Type_annot s + let unsafe_type_annot_of_string s = + Type_annot (Non_empty_string.of_string_exn s) - let unsafe_field_annot_of_string s = Field_annot s + let unsafe_field_annot_of_string s = + Field_annot (Non_empty_string.of_string_exn s) end -let default_now_annot = Some (Var_annot "now") +let some_var_annot_of_string_exn s = + Some (Var_annot (Non_empty_string.of_string_exn s)) -let default_amount_annot = Some (Var_annot "amount") +let some_field_annot_of_string_exn s = + Some (Field_annot (Non_empty_string.of_string_exn s)) -let default_balance_annot = Some (Var_annot "balance") +let default_now_annot = some_var_annot_of_string_exn "now" -let default_level_annot = Some (Var_annot "level") +let default_amount_annot = some_var_annot_of_string_exn "amount" -let default_source_annot = Some (Var_annot "source") +let default_balance_annot = some_var_annot_of_string_exn "balance" -let default_sender_annot = Some (Var_annot "sender") +let default_level_annot = some_var_annot_of_string_exn "level" -let default_self_annot = Some (Var_annot "self") +let default_source_annot = some_var_annot_of_string_exn "source" -let default_arg_annot = Some (Var_annot "arg") +let default_sender_annot = some_var_annot_of_string_exn "sender" -let lambda_arg_annot = Some (Var_annot "@arg") +let default_self_annot = some_var_annot_of_string_exn "self" -let default_param_annot = Some (Var_annot "parameter") +let default_arg_annot = some_var_annot_of_string_exn "arg" -let default_storage_annot = Some (Var_annot "storage") +let lambda_arg_annot = some_var_annot_of_string_exn "@arg" -let default_car_annot = Some (Field_annot "car") +let default_param_annot = some_var_annot_of_string_exn "parameter" -let default_cdr_annot = Some (Field_annot "cdr") +let default_storage_annot = some_var_annot_of_string_exn "storage" -let default_contract_annot = Some (Field_annot "contract") +let default_car_annot = some_field_annot_of_string_exn "car" -let default_addr_annot = Some (Field_annot "address") +let default_cdr_annot = some_field_annot_of_string_exn "cdr" -let default_pack_annot = Some (Field_annot "packed") +let default_contract_annot = some_field_annot_of_string_exn "contract" -let default_unpack_annot = Some (Field_annot "unpacked") +let default_addr_annot = some_field_annot_of_string_exn "address" -let default_slice_annot = Some (Field_annot "slice") +let default_pack_annot = some_field_annot_of_string_exn "packed" -let default_elt_annot = Some (Field_annot "elt") +let default_unpack_annot = some_field_annot_of_string_exn "unpacked" -let default_key_annot = Some (Field_annot "key") +let default_slice_annot = some_field_annot_of_string_exn "slice" -let default_hd_annot = Some (Field_annot "hd") +let default_elt_annot = some_field_annot_of_string_exn "elt" -let default_tl_annot = Some (Field_annot "tl") +let default_key_annot = some_field_annot_of_string_exn "key" -let default_some_annot = Some (Field_annot "some") +let default_hd_annot = some_field_annot_of_string_exn "hd" -let default_left_annot = Some (Field_annot "left") +let default_tl_annot = some_field_annot_of_string_exn "tl" -let default_right_annot = Some (Field_annot "right") +let default_some_annot = some_field_annot_of_string_exn "some" -let default_sapling_state_annot = Some (Var_annot "sapling") +let default_left_annot = some_field_annot_of_string_exn "left" -let default_sapling_balance_annot = Some (Var_annot "sapling_balance") +let default_right_annot = some_field_annot_of_string_exn "right" + +let default_sapling_state_annot = some_var_annot_of_string_exn "sapling" + +let default_sapling_balance_annot = + some_var_annot_of_string_exn "sapling_balance" let unparse_type_annot : type_annot option -> string list = function | None -> [] - | Some (Type_annot a) -> [":" ^ a] + | Some (Type_annot a) -> [":" ^ (a :> string)] let unparse_var_annot : var_annot option -> string list = function | None -> [] - | Some (Var_annot a) -> ["@" ^ a] + | Some (Var_annot a) -> ["@" ^ (a :> string)] let unparse_field_annot : field_annot option -> string list = function | None -> [] - | Some (Field_annot a) -> ["%" ^ a] + | Some (Field_annot a) -> ["%" ^ (a :> string)] let field_to_var_annot : field_annot option -> var_annot option = function | None -> None @@ -128,14 +138,12 @@ let gen_access_annot : var_annot option = fun value_annot ?(default = None) field_annot -> match (value_annot, field_annot, default) with - | (None, None, _) | (Some _, None, None) | (None, Some (Field_annot ""), _) -> - None + | (None, None, _) | (Some _, None, None) -> None | (None, Some (Field_annot f), _) -> Some (Var_annot f) - | (Some (Var_annot v), (None | Some (Field_annot "")), Some (Field_annot f)) - -> - Some (Var_annot (String.concat "." [v; f])) + | (Some (Var_annot v), None, Some (Field_annot f)) -> + Some (Var_annot (Non_empty_string.cat2 v ~sep:"." f)) | (Some (Var_annot v), Some (Field_annot f), _) -> - Some (Var_annot (String.concat "." [v; f])) + Some (Var_annot (Non_empty_string.cat2 v ~sep:"." f)) let merge_type_annot : legacy:bool -> @@ -146,8 +154,10 @@ let merge_type_annot : match (annot1, annot2) with | (None, None) | (Some _, None) | (None, Some _) -> Result.return_none | (Some (Type_annot a1), Some (Type_annot a2)) -> - if legacy || String.equal a1 a2 then ok annot1 - else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2)) + if legacy || Non_empty_string.(a1 = a2) then ok annot1 + else + error + (Inconsistent_annotations (":" ^ (a1 :> string), ":" ^ (a2 :> string))) let merge_field_annot : legacy:bool -> @@ -158,15 +168,17 @@ let merge_field_annot : match (annot1, annot2) with | (None, None) | (Some _, None) | (None, Some _) -> Result.return_none | (Some (Field_annot a1), Some (Field_annot a2)) -> - if legacy || String.equal a1 a2 then ok annot1 - else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) + if legacy || Non_empty_string.(a1 = a2) then ok annot1 + else + error + (Inconsistent_annotations ("%" ^ (a1 :> string), "%" ^ (a2 :> string))) let merge_var_annot : var_annot option -> var_annot option -> var_annot option = fun annot1 annot2 -> match (annot1, annot2) with | (None, None) | (Some _, None) | (None, Some _) -> None | (Some (Var_annot a1), Some (Var_annot a2)) -> - if String.equal a1 a2 then annot1 else None + if Non_empty_string.(a1 = a2) then annot1 else None let error_unexpected_annot loc annot = match annot with @@ -195,60 +207,49 @@ let check_char loc c = let max_annot_length = 255 type annot_opt = - | Field_annot_opt of string option - | Type_annot_opt of string option - | Var_annot_opt of string option + | Field_annot_opt of Non_empty_string.t option + | Type_annot_opt of Non_empty_string.t option + | Var_annot_opt of Non_empty_string.t option + +let percent = Non_empty_string.of_string_exn "%" + +let percent_percent = Non_empty_string.of_string_exn "%%" + +let at = Non_empty_string.of_string_exn "@" let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) l = (* allow empty annotations as wildcards but otherwise only accept annotations that start with [a-zA-Z_] *) - let sub_or_wildcard ~specials wrap s acc = - let mem_char c cs = List.exists (Char.equal c) cs in - let len = String.length s in - (if Compare.Int.(len > max_annot_length) then - error (Unexpected_annotation loc) - else Result.return_unit) - >>? fun () -> - if Compare.Int.(len = 1) then ok @@ wrap None :: acc - else - match s.[1] with - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> - (* check that all characters are valid*) - string_iter (check_char loc) s 2 >>? fun () -> - ok @@ wrap (Some (String.sub s 1 (len - 1))) :: acc - | '@' when Compare.Int.(len = 2) && mem_char '@' specials -> - ok @@ wrap (Some "@") :: acc - | '%' when mem_char '%' specials -> - if Compare.Int.(len = 2) then ok @@ wrap (Some "%") :: acc - else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then - ok @@ wrap (Some "%%") :: acc - else error (Unexpected_annotation loc) - | _ -> error (Unexpected_annotation loc) - in - List.fold_left_e - (fun acc s -> - if Compare.Int.(String.length s = 0) then - error (Unexpected_annotation loc) - else - match s.[0] with - | ':' -> sub_or_wildcard ~specials:[] (fun a -> Type_annot_opt a) s acc - | '@' -> - sub_or_wildcard - ~specials:(if allow_special_var then ['%'] else []) - (fun a -> Var_annot_opt a) - s - acc - | '%' -> - sub_or_wildcard - ~specials:(if allow_special_field then ['@'] else []) - (fun a -> Field_annot_opt a) - s - acc + let sub_or_wildcard wrap s = + match Non_empty_string.of_string s with + | None -> ok @@ wrap None + | Some s -> ( + match (s :> string).[0] with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> + (* check that all characters are valid*) + string_iter (check_char loc) (s :> string) 1 >>? fun () -> + ok @@ wrap (Some s) | _ -> error (Unexpected_annotation loc)) - [] + in + List.map_e + (function + | "@%" when allow_special_var -> ok @@ Var_annot_opt (Some percent) + | "@%%" when allow_special_var -> + ok @@ Var_annot_opt (Some percent_percent) + | "%@" when allow_special_field -> ok @@ Field_annot_opt (Some at) + | s -> ( + let len = String.length s in + if Compare.Int.(len = 0 || len > max_annot_length) then + error (Unexpected_annotation loc) + else + let rest = String.sub s 1 (len - 1) in + match s.[0] with + | ':' -> sub_or_wildcard (fun a -> Type_annot_opt a) rest + | '@' -> sub_or_wildcard (fun a -> Var_annot_opt a) rest + | '%' -> sub_or_wildcard (fun a -> Field_annot_opt a) rest + | _ -> error (Unexpected_annotation loc))) l - >|? List.rev let opt_var_of_var_opt = function None -> None | Some a -> Some (Var_annot a) @@ -342,8 +343,11 @@ let check_correct_field : match (f1, f2) with | (None, _) | (_, None) -> Result.return_unit | (Some (Field_annot s1), Some (Field_annot s2)) -> - if String.equal s1 s2 then Result.return_unit - else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2)) + if Non_empty_string.(s1 = s2) then Result.return_unit + else + error + (Inconsistent_field_annotations + ("%" ^ (s1 :> string), "%" ^ (s2 :> string))) let parse_var_annot : Script.location -> @@ -361,21 +365,27 @@ let parse_var_annot : let split_last_dot = function | None -> (None, None) | Some (Field_annot s) -> ( - match String.rindex_opt s '.' with - | None -> (None, Some (Field_annot s)) - | Some i -> - let s1 = String.sub s 0 i in - let s2 = String.sub s (i + 1) (String.length s - i - 1) in + match Non_empty_string.split_on_last '.' s with + | Some (s1, s2) -> let f = - if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr" - then None - else Some (Field_annot s2) + match (s2 :> string) with + | "car" | "cdr" -> None + | _ -> Some (Field_annot s2) in - (Some (Var_annot s1), f)) + (Some (Var_annot s1), f) + | None -> (None, Some (Field_annot s))) + +let split_if_special ~loc ~if_special v f = + match f with + | Some (Field_annot fa) when Non_empty_string.(fa = at) -> ( + match if_special with + | Some special_var -> ok @@ split_last_dot special_var + | None -> error (Unexpected_annotation loc)) + | _ -> ok (v, f) let common_prefix v1 v2 = match (v1, v2) with - | (Some (Var_annot s1), Some (Var_annot s2)) when Compare.String.equal s1 s2 + | (Some (Var_annot s1), Some (Var_annot s2)) when Non_empty_string.(s1 = s2) -> v1 | (Some _, None) -> v1 @@ -398,18 +408,8 @@ let parse_constr_annot : get_one_annot loc vars >>? fun v -> get_one_annot loc types >>? fun t -> get_two_annot loc fields >>? fun (f1, f2) -> - (match (if_special_first, f1) with - | (Some special_var, Some (Field_annot "@")) -> - ok (split_last_dot special_var) - | (None, Some (Field_annot "@")) -> error (Unexpected_annotation loc) - | (_, _) -> ok (v, f1)) - >>? fun (v1, f1) -> - (match (if_special_second, f2) with - | (Some special_var, Some (Field_annot "@")) -> - ok (split_last_dot special_var) - | (None, Some (Field_annot "@")) -> error (Unexpected_annotation loc) - | (_, _) -> ok (v, f2)) - >|? fun (v2, f2) -> + split_if_special ~loc ~if_special:if_special_first v f1 >>? fun (v1, f1) -> + split_if_special ~loc ~if_special:if_special_second v f2 >|? fun (v2, f2) -> let v = match v with None -> common_prefix v1 v2 | Some _ -> v in (v, t, f1, f2) @@ -430,9 +430,11 @@ let var_annot_from_special : var_annot option = fun ~field_name ~default ~value_annot v -> match v with - | Some (Var_annot "%") -> field_to_var_annot field_name - | Some (Var_annot "%%") -> default - | Some _ -> v + | Some (Var_annot va) -> ( + match (va :> string) with + | "%" -> field_to_var_annot field_name + | "%%" -> default + | _ -> v) | None -> value_annot let parse_destr_annot : diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.mli b/src/proto_alpha/lib_protocol/script_ir_annot.mli index d8b4f660fe76b2efe07c4501a583e7ee68707f35..47fab3b005b29b8954283f0a9658be1e8d2deda3 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.mli +++ b/src/proto_alpha/lib_protocol/script_ir_annot.mli @@ -25,11 +25,11 @@ open Alpha_context -type var_annot = private Var_annot of string [@@ocaml.unboxed] +type var_annot = private Var_annot of Non_empty_string.t [@@ocaml.unboxed] -type type_annot = private Type_annot of string [@@ocaml.unboxed] +type type_annot = private Type_annot of Non_empty_string.t [@@ocaml.unboxed] -type field_annot = private Field_annot of string [@@ocaml.unboxed] +type field_annot = private Field_annot of Non_empty_string.t [@@ocaml.unboxed] module FOR_TESTS : sig val unsafe_var_annot_of_string : string -> var_annot diff --git a/src/proto_alpha/lib_protocol/script_ir_translator.ml b/src/proto_alpha/lib_protocol/script_ir_translator.ml index bee749ce33e1f4a6963ea78c08cd2638076b50d9..3ff03061bfaa7fa4c2fd259c64cdd42cce7b1a4d 100644 --- a/src/proto_alpha/lib_protocol/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/script_ir_translator.ml @@ -1996,7 +1996,7 @@ type 'before dup_n_proof_argument = let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = let annot_is_entrypoint entrypoint = function | None -> false - | Some (Field_annot l) -> Compare.String.(l = entrypoint) + | Some (Field_annot l) -> Compare.String.((l :> string) = entrypoint) in let loc = Micheline.dummy_location in let rec find_entrypoint : @@ -2025,8 +2025,8 @@ let find_entrypoint (type full) (full : full ty) ~root_name entrypoint = error (Entrypoint_name_too_long entrypoint) else match root_name with - | Some (Field_annot root_name) when Compare.String.(entrypoint = root_name) - -> + | Some (Field_annot root_name) + when Compare.String.(entrypoint = (root_name :> string)) -> ok ((fun e -> e), Ex_ty full) | _ -> ( match find_entrypoint full entrypoint with @@ -2046,7 +2046,8 @@ let find_entrypoint_for_type (type full exp) ~legacy ~merge_type_error_flag merge_types ~legacy ~merge_type_error_flag loc ty expected >??$ fun eq_ty -> match (entrypoint, root_name) with - | ("default", Some (Field_annot "root")) -> ( + | ("default", Some (Field_annot fa)) + when Compare.String.((fa :> string) = "root") -> ( match eq_ty with | Ok (Eq, ty) -> return ("default", (ty : exp ty)) | Error _ -> @@ -2060,7 +2061,7 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = let merge path annot (type t) (ty : t ty) reachable ((first_unreachable, all) as acc) = match annot with - | None | Some (Field_annot "") -> + | None -> ok (if reachable then acc else @@ -2071,6 +2072,7 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = | None -> (Some (List.rev path), all) | Some _ -> acc)) | Some (Field_annot name) -> + let name = (name :> string) in if Compare.Int.(String.length name > 31) then error (Entrypoint_name_too_long name) else if Entrypoints.mem name all then error (Duplicate_entrypoint name) @@ -2103,8 +2105,8 @@ let well_formed_entrypoints (type full) (full : full ty) ~root_name = in let (init, reachable) = match root_name with - | None | Some (Field_annot "") -> (Entrypoints.empty, false) - | Some (Field_annot name) -> (Entrypoints.singleton name, true) + | None -> (Entrypoints.empty, false) + | Some (Field_annot name) -> (Entrypoints.singleton (name :> string), true) in check full [] reachable (None, init) >>? fun (first_unreachable, all) -> if not (Entrypoints.mem "default" all) then Result.return_unit @@ -4789,9 +4791,11 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>?= fun (annot, entrypoint) -> (match entrypoint with | None -> Ok "default" - | Some (Field_annot "default") -> error (Unexpected_annotation loc) | Some (Field_annot entrypoint) -> - if Compare.Int.(String.length entrypoint > 31) then + let entrypoint = (entrypoint :> string) in + if Compare.String.(entrypoint = "default") then + error (Unexpected_annotation loc) + else if Compare.Int.(String.length entrypoint > 31) then error (Entrypoint_name_too_long entrypoint) else Ok entrypoint) >>?= fun entrypoint -> @@ -4989,7 +4993,7 @@ and[@coq_axiom_with_reason "gadt"] parse_instr : >>? fun (annot, entrypoint) -> let entrypoint = Option.fold - ~some:(fun (Field_annot annot) -> annot) + ~some:(fun (Field_annot annot) -> (annot :> string)) ~none:"default" entrypoint in @@ -5873,7 +5877,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = let merge path annot (type t) (ty : t ty) reachable ((unreachables, all) as acc) = match annot with - | None | Some (Field_annot "") -> ( + | None -> ( ok @@ if reachable then acc @@ -5882,6 +5886,7 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = | Union_t _ -> acc | _ -> (List.rev path :: unreachables, all)) | Some (Field_annot name) -> + let name = (name :> string) in if Compare.Int.(String.length name > 31) then ok (List.rev path :: unreachables, all) else if Entrypoints_map.mem name all then @@ -5923,9 +5928,9 @@ let list_entrypoints (type full) (full : full ty) ctxt ~root_name = unparse_ty ~loc:() ctxt full >>? fun (unparsed_full, _) -> let (init, reachable) = match root_name with - | None | Some (Field_annot "") -> (Entrypoints_map.empty, false) + | None -> (Entrypoints_map.empty, false) | Some (Field_annot name) -> - (Entrypoints_map.singleton name ([], unparsed_full), true) + (Entrypoints_map.singleton (name :> string) ([], unparsed_full), true) in fold_tree full [] reachable ([], init) [@@coq_axiom_with_reason "unsupported syntax"]