From ab4c363579ab40d337cbe1520ff4110ab0912611 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 25 Oct 2021 19:11:58 +0200 Subject: [PATCH 1/9] Proto/annots: use List.map_e in parse_annots --- .../lib_protocol/script_ir_annot.ml | 22 ++++++++----------- 1 file changed, 9 insertions(+), 13 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 9b1f60dbe404..1c57e6be40c4 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -203,52 +203,48 @@ 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 sub_or_wildcard ~specials wrap s = 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 + if Compare.Int.(len = 1) then ok @@ wrap None 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 + ok @@ wrap (Some (String.sub s 1 (len - 1))) | '@' when Compare.Int.(len = 2) && mem_char '@' specials -> - ok @@ wrap (Some "@") :: acc + ok @@ wrap (Some "@") | '%' when mem_char '%' specials -> - if Compare.Int.(len = 2) then ok @@ wrap (Some "%") :: acc + if Compare.Int.(len = 2) then ok @@ wrap (Some "%") else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then - ok @@ wrap (Some "%%") :: acc + ok @@ wrap (Some "%%") else error (Unexpected_annotation loc) | _ -> error (Unexpected_annotation loc) in - List.fold_left_e - (fun acc s -> + List.map_e + (fun 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:[] (fun a -> Type_annot_opt a) s | '@' -> 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 | _ -> error (Unexpected_annotation loc)) - [] l - >|? List.rev let opt_var_of_var_opt = function None -> None | Some a -> Some (Var_annot a) -- GitLab From 97c04b5251d01d67235c3d10a3d4dc6f01bb2dc1 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 25 Oct 2021 19:30:45 +0200 Subject: [PATCH 2/9] Proto/annots: simplify parse_annots (1/2) --- .../lib_protocol/script_ir_annot.ml | 40 +++++++------------ 1 file changed, 14 insertions(+), 26 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 1c57e6be40c4..eb0759ae0d26 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -203,8 +203,7 @@ 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 = - let mem_char c cs = List.exists (Char.equal c) cs in + let sub_or_wildcard wrap s = let len = String.length s in (if Compare.Int.(len > max_annot_length) then error (Unexpected_annotation loc) @@ -217,33 +216,22 @@ let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) (* check that all characters are valid*) string_iter (check_char loc) s 2 >>? fun () -> ok @@ wrap (Some (String.sub s 1 (len - 1))) - | '@' when Compare.Int.(len = 2) && mem_char '@' specials -> - ok @@ wrap (Some "@") - | '%' when mem_char '%' specials -> - if Compare.Int.(len = 2) then ok @@ wrap (Some "%") - else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then - ok @@ wrap (Some "%%") - else error (Unexpected_annotation loc) | _ -> error (Unexpected_annotation loc) in List.map_e - (fun 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 - | '@' -> - sub_or_wildcard - ~specials:(if allow_special_var then ['%'] else []) - (fun a -> Var_annot_opt a) - s - | '%' -> - sub_or_wildcard - ~specials:(if allow_special_field then ['@'] else []) - (fun a -> Field_annot_opt a) - s - | _ -> error (Unexpected_annotation loc)) + (function + | "@%" when allow_special_var -> ok @@ Var_annot_opt (Some "%") + | "@%%" when allow_special_var -> ok @@ Var_annot_opt (Some "%%") + | "%@" when allow_special_field -> ok @@ Field_annot_opt (Some "@") + | s -> ( + if Compare.Int.(String.length s = 0) then + error (Unexpected_annotation loc) + else + match s.[0] with + | ':' -> sub_or_wildcard (fun a -> Type_annot_opt a) s + | '@' -> sub_or_wildcard (fun a -> Var_annot_opt a) s + | '%' -> sub_or_wildcard (fun a -> Field_annot_opt a) s + | _ -> error (Unexpected_annotation loc))) l let opt_var_of_var_opt = function None -> None | Some a -> Some (Var_annot a) -- GitLab From aa2ff5eaf3f5ab04a68e6e0e2122424b45e5622d Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Mon, 25 Oct 2021 19:24:07 +0200 Subject: [PATCH 3/9] Proto/annots: simplify parse_annots (2/2) --- .../lib_protocol/script_ir_annot.ml | 21 ++++++++----------- 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index eb0759ae0d26..8523e6e045e8 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -205,17 +205,12 @@ let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) annotations that start with [a-zA-Z_] *) let sub_or_wildcard wrap s = 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 + if Compare.Int.(len = 0) then ok @@ wrap None else - match s.[1] with + match s.[0] 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))) + string_iter (check_char loc) s 1 >>? fun () -> ok @@ wrap (Some s) | _ -> error (Unexpected_annotation loc) in List.map_e @@ -224,13 +219,15 @@ let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false) | "@%%" when allow_special_var -> ok @@ Var_annot_opt (Some "%%") | "%@" when allow_special_field -> ok @@ Field_annot_opt (Some "@") | s -> ( - if Compare.Int.(String.length s = 0) then + 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) s - | '@' -> sub_or_wildcard (fun a -> Var_annot_opt a) s - | '%' -> sub_or_wildcard (fun a -> Field_annot_opt a) s + | ':' -> 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 -- GitLab From 3cf9e05f500c48af48c3f6138ec44b8cad163d30 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 27 Oct 2021 18:51:03 +0200 Subject: [PATCH 4/9] Proto/annots: factorize parse_constr_annot --- .../lib_protocol/script_ir_annot.ml | 22 +++++++++---------- 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 8523e6e045e8..c8e4d22e8187 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -354,6 +354,14 @@ let split_last_dot = function in (Some (Var_annot s1), f)) +let split_if_special ~loc ~if_special v f = + match f with + | Some (Field_annot "@") -> ( + 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 @@ -379,18 +387,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) -- GitLab From 4c233614ab4fffea75e23ffedad39285f524ccfc Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Wed, 27 Oct 2021 18:59:16 +0200 Subject: [PATCH 5/9] Proto/annots: disallow producing empty annotations --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index c8e4d22e8187..ad50a4e6b849 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -343,8 +343,7 @@ 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 -> + | 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 - i - 1) in let f = @@ -352,7 +351,8 @@ let split_last_dot = function then None else Some (Field_annot s2) in - (Some (Var_annot s1), f)) + (Some (Var_annot s1), f) + | _ -> (None, Some (Field_annot s))) let split_if_special ~loc ~if_special v f = match f with -- GitLab From a9dbafca371a51536ed0259fced7bdfb9ceea4bd Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 28 Oct 2021 08:10:58 +0200 Subject: [PATCH 6/9] Proto: add Non_empty_string --- src/proto_alpha/lib_protocol/TEZOS_PROTOCOL | 1 + src/proto_alpha/lib_protocol/dune.inc | 5 +++ .../lib_protocol/non_empty_string.ml | 42 +++++++++++++++++ .../lib_protocol/non_empty_string.mli | 45 +++++++++++++++++++ 4 files changed, 93 insertions(+) create mode 100644 src/proto_alpha/lib_protocol/non_empty_string.ml create mode 100644 src/proto_alpha/lib_protocol/non_empty_string.mli diff --git a/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/TEZOS_PROTOCOL index 38e90299cc53..1a58a2a875f1 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 3e63ce628659..8065285538dd 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 000000000000..9ce9b11d27e8 --- /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 000000000000..a9973efd775f --- /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 -- GitLab From 69831bde9e6e2fea69aeecb2d398ab6492cf7101 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 28 Oct 2021 08:09:32 +0200 Subject: [PATCH 7/9] Proto/annots: helper to construct default hardcoded annotations (1/2) This is just to make next diff more readable --- src/proto_alpha/lib_protocol/script_ir_annot.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index ad50a4e6b849..900757ce70de 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -41,6 +41,10 @@ module FOR_TESTS = struct let unsafe_field_annot_of_string s = Field_annot s end +let some_var_annot_of_string_exn s = Some (Var_annot s) + +let some_field_annot_of_string_exn s = Some (Field_annot s) + let default_now_annot = Some (Var_annot "now") let default_amount_annot = Some (Var_annot "amount") -- GitLab From 40b76c2615427fc11d67435f88fd9282adbab762 Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Thu, 28 Oct 2021 08:09:32 +0200 Subject: [PATCH 8/9] Proto/annots: helper to construct default hardcoded annotations (2/2) This is just to make next diff smaller --- .../lib_protocol/script_ir_annot.ml | 55 ++++++++++--------- 1 file changed, 28 insertions(+), 27 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 900757ce70de..0c1fbb4ed068 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -45,59 +45,60 @@ let some_var_annot_of_string_exn s = Some (Var_annot s) let some_field_annot_of_string_exn s = Some (Field_annot s) -let default_now_annot = Some (Var_annot "now") +let default_now_annot = some_var_annot_of_string_exn "now" -let default_amount_annot = Some (Var_annot "amount") +let default_amount_annot = some_var_annot_of_string_exn "amount" -let default_balance_annot = Some (Var_annot "balance") +let default_balance_annot = some_var_annot_of_string_exn "balance" -let default_level_annot = Some (Var_annot "level") +let default_level_annot = some_var_annot_of_string_exn "level" -let default_source_annot = Some (Var_annot "source") +let default_source_annot = some_var_annot_of_string_exn "source" -let default_sender_annot = Some (Var_annot "sender") +let default_sender_annot = some_var_annot_of_string_exn "sender" -let default_self_annot = Some (Var_annot "self") +let default_self_annot = some_var_annot_of_string_exn "self" -let default_arg_annot = Some (Var_annot "arg") +let default_arg_annot = some_var_annot_of_string_exn "arg" -let lambda_arg_annot = Some (Var_annot "@arg") +let lambda_arg_annot = some_var_annot_of_string_exn "@arg" -let default_param_annot = Some (Var_annot "parameter") +let default_param_annot = some_var_annot_of_string_exn "parameter" -let default_storage_annot = Some (Var_annot "storage") +let default_storage_annot = some_var_annot_of_string_exn "storage" -let default_car_annot = Some (Field_annot "car") +let default_car_annot = some_field_annot_of_string_exn "car" -let default_cdr_annot = Some (Field_annot "cdr") +let default_cdr_annot = some_field_annot_of_string_exn "cdr" -let default_contract_annot = Some (Field_annot "contract") +let default_contract_annot = some_field_annot_of_string_exn "contract" -let default_addr_annot = Some (Field_annot "address") +let default_addr_annot = some_field_annot_of_string_exn "address" -let default_pack_annot = Some (Field_annot "packed") +let default_pack_annot = some_field_annot_of_string_exn "packed" -let default_unpack_annot = Some (Field_annot "unpacked") +let default_unpack_annot = some_field_annot_of_string_exn "unpacked" -let default_slice_annot = Some (Field_annot "slice") +let default_slice_annot = some_field_annot_of_string_exn "slice" -let default_elt_annot = Some (Field_annot "elt") +let default_elt_annot = some_field_annot_of_string_exn "elt" -let default_key_annot = Some (Field_annot "key") +let default_key_annot = some_field_annot_of_string_exn "key" -let default_hd_annot = Some (Field_annot "hd") +let default_hd_annot = some_field_annot_of_string_exn "hd" -let default_tl_annot = Some (Field_annot "tl") +let default_tl_annot = some_field_annot_of_string_exn "tl" -let default_some_annot = Some (Field_annot "some") +let default_some_annot = some_field_annot_of_string_exn "some" -let default_left_annot = Some (Field_annot "left") +let default_left_annot = some_field_annot_of_string_exn "left" -let default_right_annot = Some (Field_annot "right") +let default_right_annot = some_field_annot_of_string_exn "right" -let default_sapling_state_annot = Some (Var_annot "sapling") +let default_sapling_state_annot = some_var_annot_of_string_exn "sapling" -let default_sapling_balance_annot = Some (Var_annot "sapling_balance") +let default_sapling_balance_annot = + some_var_annot_of_string_exn "sapling_balance" let unparse_type_annot : type_annot option -> string list = function | None -> [] -- GitLab From 8ff19d7453374f8958911698b09f5f18fc14f71d Mon Sep 17 00:00:00 2001 From: Mehdi Bouaziz Date: Tue, 26 Oct 2021 17:55:26 +0200 Subject: [PATCH 9/9] Proto/annots: annotations are non-empty strings --- .../lib_protocol/script_ir_annot.ml | 120 ++++++++++-------- .../lib_protocol/script_ir_annot.mli | 6 +- .../lib_protocol/script_ir_translator.ml | 31 +++-- 3 files changed, 90 insertions(+), 67 deletions(-) diff --git a/src/proto_alpha/lib_protocol/script_ir_annot.ml b/src/proto_alpha/lib_protocol/script_ir_annot.ml index 0c1fbb4ed068..90ac3451266a 100644 --- a/src/proto_alpha/lib_protocol/script_ir_annot.ml +++ b/src/proto_alpha/lib_protocol/script_ir_annot.ml @@ -27,23 +27,28 @@ 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 some_var_annot_of_string_exn s = Some (Var_annot s) +let some_var_annot_of_string_exn s = + Some (Var_annot (Non_empty_string.of_string_exn s)) -let some_field_annot_of_string_exn s = Some (Field_annot s) +let some_field_annot_of_string_exn s = + Some (Field_annot (Non_empty_string.of_string_exn s)) let default_now_annot = some_var_annot_of_string_exn "now" @@ -102,15 +107,15 @@ let default_sapling_balance_annot = 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 @@ -133,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 -> @@ -151,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 -> @@ -163,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 @@ -200,29 +207,37 @@ 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 wrap s = - let len = String.length s in - if Compare.Int.(len = 0) then ok @@ wrap None - else - match s.[0] with - | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> - (* check that all characters are valid*) - string_iter (check_char loc) s 1 >>? fun () -> ok @@ wrap (Some s) - | _ -> error (Unexpected_annotation loc) + 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 "%") - | "@%%" when allow_special_var -> ok @@ Var_annot_opt (Some "%%") - | "%@" when allow_special_field -> ok @@ Field_annot_opt (Some "@") + | "@%" 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 @@ -328,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 -> @@ -347,21 +365,19 @@ let parse_var_annot : let split_last_dot = function | None -> (None, None) | Some (Field_annot s) -> ( - match String.rindex_opt s '.' 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 - 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) - | _ -> (None, Some (Field_annot s))) + | None -> (None, Some (Field_annot s))) let split_if_special ~loc ~if_special v f = match f with - | Some (Field_annot "@") -> ( + | 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)) @@ -369,7 +385,7 @@ let split_if_special ~loc ~if_special 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 @@ -414,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 d8b4f660fe76..47fab3b005b2 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 bee749ce33e1..3ff03061bfaa 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"] -- GitLab