From 42393b528236921588776348a7c408d423b2e0f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Thu, 23 Nov 2023 11:26:47 +0100 Subject: [PATCH 1/9] Client/Michelson/Stacks: avoid record_trace This commit delays the computation of errors to avoid traversing the nodes when the error is not thrown. --- src/proto_alpha/lib_client/michelson_v1_stack.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index 3800dd11425d..c484ae5b1297 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -237,13 +237,13 @@ let parse_extra_big_map_item ~source = let parse_stack ~source = function | Micheline.Seq (loc, l) as e -> - record_trace (Wrong_stack (loc, printable e)) + record_trace_eval (fun () -> Wrong_stack (loc, printable e)) @@ List.map_e (parse_stack_item ~source) l | e -> Result_syntax.tzfail (Wrong_stack (Micheline.location e, printable e)) let parse_other_contracts ~source = function | Micheline.Seq (loc, l) as e -> - record_trace (Wrong_other_contracts (loc, printable e)) + record_trace_eval (fun () -> Wrong_other_contracts (loc, printable e)) @@ List.map_e (parse_other_contract_item ~source) l | e -> Result_syntax.tzfail @@ -251,7 +251,7 @@ let parse_other_contracts ~source = function let parse_extra_big_maps ~source = function | Micheline.Seq (loc, l) as e -> - record_trace (Wrong_extra_big_maps (loc, printable e)) + record_trace_eval (fun () -> Wrong_extra_big_maps (loc, printable e)) @@ List.map_e (parse_extra_big_map_item ~source) l | e -> Result_syntax.tzfail -- GitLab From 57c6f360b10c02c18a0dffa73783e263f712f737 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 10 Nov 2023 13:43:36 +0100 Subject: [PATCH 2/9] Client/Michelson/Stacks: introduce localized nodes --- .../lib_client/michelson_v1_error_reporter.ml | 24 +-- .../lib_client/michelson_v1_stack.ml | 178 +++++++++--------- 2 files changed, 102 insertions(+), 100 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml index 3a913feacc55..580e47209176 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -194,26 +194,26 @@ let report_errors ~details ~show_source ?parsed ppf errs = in match errs with | [] -> () - | Michelson_v1_stack.Wrong_stack_item (loc, expr) :: rest -> + | Michelson_v1_stack.Wrong_stack_item loc_node :: rest -> Format.fprintf ppf - "@[%s,@ wrong syntax for a stack element, expecting something \ + "@[%a,@ wrong syntax for a stack element, expecting something \ of the following shape: Stack_elt ; got %a.@]" - (String.capitalize_ascii - (Format.asprintf "%a" Micheline_parser.print_location loc)) - Micheline_printer.print_expr_unwrapped - expr ; + Michelson_v1_stack.print_localized_node_location + loc_node + Michelson_v1_stack.print_localized_node + loc_node ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest - | Michelson_v1_stack.Wrong_stack (loc, expr) :: rest -> + | Michelson_v1_stack.Wrong_stack loc_node :: rest -> Format.fprintf ppf - "@[%s,@ wrong syntax for stack, expecting a sequence of \ + "@[%a,@ wrong syntax for stack, expecting a sequence of \ elements of the following shape: Stack_elt ; got %a.@]" - (String.capitalize_ascii - (Format.asprintf "%a" Micheline_parser.print_location loc)) - Micheline_printer.print_expr_unwrapped - expr ; + Michelson_v1_stack.print_localized_node_location + loc_node + Michelson_v1_stack.print_localized_node + loc_node ; if rest <> [] then Format.fprintf ppf "@," ; print_trace locations rest | Environment.Ecoproto_error diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index c484ae5b1297..c9422c170627 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -27,16 +27,30 @@ open Tezos_micheline open Protocol open Alpha_context -type error += - | Wrong_stack_item of Micheline_parser.location * Micheline_printer.node - | Wrong_stack of Micheline_parser.location * Micheline_printer.node - | Wrong_other_contracts_item of - Micheline_parser.location * Micheline_printer.node - | Wrong_other_contracts of Micheline_parser.location * Micheline_printer.node - | Wrong_extra_big_maps_item of - Micheline_parser.location * Micheline_printer.node - | Wrong_extra_big_maps of Micheline_parser.location * Micheline_printer.node - | Invalid_address_for_smart_contract of string +type localized_node = { + loc : Micheline_parser.location; + node : Micheline_printer.node; +} + +let print_localized_node_location fmt localized_node = + Format.fprintf + fmt + "%s" + (Format.kasprintf + String.capitalize_ascii + "%a" + Micheline_parser.print_location + localized_node.loc) + +let print_localized_node fmt localized_node = + Micheline_printer.print_expr_unwrapped fmt localized_node.node + +let localize_node (n : (Micheline_parser.location, string) Micheline.node) : + localized_node = + { + loc = Micheline.location n; + node = Micheline_printer.printable Fun.id (Micheline.strip_locations n); + } let micheline_printer_location_encoding : Micheline_printer.location Data_encoding.encoding = @@ -46,122 +60,121 @@ let micheline_printer_location_encoding : (fun comment -> {comment}) (option string) -let micheline_printer_node_encoding : - Micheline_printer.node Data_encoding.encoding = - Micheline_encoding.table_encoding - ~variant:"" - micheline_printer_location_encoding - Data_encoding.string +let localized_node_encoding : localized_node Data_encoding.t = + Data_encoding.( + conv + (fun {loc; node} -> (loc, node)) + (fun (loc, node) -> {loc; node}) + (obj2 + (req "location" Micheline_parser.location_encoding) + (req + "node" + (Micheline_encoding.table_encoding + ~variant:"" + micheline_printer_location_encoding + Data_encoding.string)))) + +type error += + | Wrong_stack_item of localized_node + | Wrong_stack of localized_node + | Wrong_other_contracts_item of localized_node + | Wrong_other_contracts of localized_node + | Wrong_extra_big_maps_item of localized_node + | Wrong_extra_big_maps of localized_node + | Invalid_address_for_smart_contract of string let () = - let open Data_encoding in Protocol_client_context.register_error_kind `Permanent ~id:"michelson.stack.wrong_stack_item" ~title:"Wrong stack item" ~description:"Failed to parse an item in a typed stack." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for an item in a typed stack. Expected: Stack_elt \ ; got %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function Wrong_stack_item (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_stack_item (loc, node)) ; + localized_node_encoding + (function Wrong_stack_item node -> Some node | _ -> None) + (fun node -> Wrong_stack_item node) ; Protocol_client_context.register_error_kind `Permanent ~id:"michelson.stack.wrong_stack" ~title:"Wrong stack" ~description:"Failed to parse a typed stack." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for a typed stack. Expected a sequence of Stack_elt \ ; got %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function Wrong_stack (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_stack (loc, node)) ; + localized_node_encoding + (function Wrong_stack node -> Some node | _ -> None) + (fun node -> Wrong_stack node) ; Protocol_client_context.register_error_kind `Permanent ~id:"michelson.wrong_other_contracts_item" ~title:"Wrong description of an other contract" ~description:"Failed to parse an item in a description of other contracts." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for an item in a description of other contracts. \ Expected: Contract
; got %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function - | Wrong_other_contracts_item (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_other_contracts_item (loc, node)) ; + localized_node_encoding + (function Wrong_other_contracts_item node -> Some node | _ -> None) + (fun node -> Wrong_other_contracts_item node) ; Protocol_client_context.register_error_kind `Permanent ~id:"michelson.wrong_other_contracts" ~title:"Wrong description of a list of other contracts" ~description:"Failed to parse a description of other contracts." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for a description of other contracts. Expected a \ sequence of Contract
; got %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function - | Wrong_other_contracts (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_other_contracts (loc, node)) ; + localized_node_encoding + (function Wrong_other_contracts node -> Some node | _ -> None) + (fun node -> Wrong_other_contracts node) ; Protocol_client_context.register_error_kind `Permanent ~id:"michelson.wrong_extra_big_maps_item" ~title:"Wrong description of an extra big map" ~description:"Failed to parse an item in a description of extra big maps." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for an item in a description of extra big maps. \ Expected: Big_map ; got %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function - | Wrong_extra_big_maps_item (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_extra_big_maps_item (loc, node)) ; + localized_node_encoding + (function Wrong_extra_big_maps_item node -> Some node | _ -> None) + (fun node -> Wrong_extra_big_maps_item node) ; Protocol_client_context.register_error_kind `Permanent ~id:"michelson.wrong_extra_big_maps" ~title:"Wrong description of a list of extra big maps" ~description:"Failed to parse a description of extra big maps." - ~pp:(fun ppf (_loc, node) -> + ~pp:(fun ppf node -> Format.fprintf ppf "Unexpected format for a description of extra big maps. Expected a \ sequence of Big_map ; got \ %a." - Micheline_printer.print_expr_unwrapped + print_localized_node node) - (obj2 - (req "location" Micheline_parser.location_encoding) - (req "node" micheline_printer_node_encoding)) - (function - | Wrong_extra_big_maps (loc, node) -> Some (loc, node) | _ -> None) - (fun (loc, node) -> Wrong_extra_big_maps (loc, node)) ; + localized_node_encoding + (function Wrong_extra_big_maps node -> Some node | _ -> None) + (fun node -> Wrong_extra_big_maps node) ; Protocol_client_context.register_error_kind `Permanent ~id:"InvalidAddressForSmartContract" @@ -186,9 +199,6 @@ let parse_expression ~source (node : Micheline_parser.node) : let* parsed = Micheline_parser.no_parsing_error parsing_result in return parsed.expanded -let printable node = - Micheline_printer.printable Fun.id (Micheline.strip_locations node) - let parse_stack_item ~source = let open Result_syntax in function @@ -196,7 +206,7 @@ let parse_stack_item ~source = let* ty = parse_expression ~source ty in let* v = parse_expression ~source v in return (ty, v) - | e -> tzfail (Wrong_stack_item (Micheline.location e, printable e)) + | e -> tzfail (Wrong_stack_item (localize_node e)) let parse_other_contract_item ~source = let open Result_syntax in @@ -209,13 +219,11 @@ let parse_other_contract_item ~source = match Environment.Base58.decode s with | Some (Contract_hash.Data h) -> return h | Some _ | None -> tzfail (Invalid_address_for_smart_contract s)) - | _ -> - tzfail - (Wrong_other_contracts_item (Micheline.location e, printable e)) + | _ -> tzfail (Wrong_other_contracts_item (localize_node e)) in let* ty = parse_expression ~source ty in return RPC.Scripts.S.{address; ty} - | e -> tzfail (Wrong_other_contracts_item (Micheline.location e, printable e)) + | e -> tzfail (Wrong_other_contracts_item (localize_node e)) let parse_extra_big_map_item ~source = let open Result_syntax in @@ -225,34 +233,28 @@ let parse_extra_big_map_item ~source = let* id = match Micheline.root id with | Micheline.Int (_loc, id) -> return (Big_map.Id.parse_z id) - | _ -> - tzfail - (Wrong_other_contracts_item (Micheline.location e, printable e)) + | _ -> tzfail (Wrong_other_contracts_item (localize_node e)) in let* kty = parse_expression ~source kty in let* vty = parse_expression ~source vty in let* items = parse_expression ~source items in return RPC.Scripts.S.{id; kty; vty; items} - | e -> tzfail (Wrong_extra_big_maps_item (Micheline.location e, printable e)) + | e -> tzfail (Wrong_extra_big_maps_item (localize_node e)) let parse_stack ~source = function - | Micheline.Seq (loc, l) as e -> - record_trace_eval (fun () -> Wrong_stack (loc, printable e)) + | Micheline.Seq (_loc, l) as e -> + record_trace_eval (fun () -> Wrong_stack (localize_node e)) @@ List.map_e (parse_stack_item ~source) l - | e -> Result_syntax.tzfail (Wrong_stack (Micheline.location e, printable e)) + | e -> Result_syntax.tzfail (Wrong_stack (localize_node e)) let parse_other_contracts ~source = function - | Micheline.Seq (loc, l) as e -> - record_trace_eval (fun () -> Wrong_other_contracts (loc, printable e)) + | Micheline.Seq (_loc, l) as e -> + record_trace_eval (fun () -> Wrong_other_contracts (localize_node e)) @@ List.map_e (parse_other_contract_item ~source) l - | e -> - Result_syntax.tzfail - (Wrong_other_contracts (Micheline.location e, printable e)) + | e -> Result_syntax.tzfail (Wrong_other_contracts (localize_node e)) let parse_extra_big_maps ~source = function - | Micheline.Seq (loc, l) as e -> - record_trace_eval (fun () -> Wrong_extra_big_maps (loc, printable e)) + | Micheline.Seq (_loc, l) as e -> + record_trace_eval (fun () -> Wrong_extra_big_maps (localize_node e)) @@ List.map_e (parse_extra_big_map_item ~source) l - | e -> - Result_syntax.tzfail - (Wrong_extra_big_maps (Micheline.location e, printable e)) + | e -> Result_syntax.tzfail (Wrong_extra_big_maps (localize_node e)) -- GitLab From 5901eae709fa5736b129907c41df3f78c4dd2103 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 17 Nov 2023 09:49:13 +0100 Subject: [PATCH 3/9] Client/Michelson/Stacks: add an interface --- .../lib_client/michelson_v1_stack.mli | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) create mode 100644 src/proto_alpha/lib_client/michelson_v1_stack.mli diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.mli b/src/proto_alpha/lib_client/michelson_v1_stack.mli new file mode 100644 index 000000000000..aadada2b2b29 --- /dev/null +++ b/src/proto_alpha/lib_client/michelson_v1_stack.mli @@ -0,0 +1,40 @@ +(*****************************************************************************) +(* *) +(* SPDX-License-Identifier: MIT *) +(* Copyright (c) 2023 Nomadic Labs *) +(* *) +(*****************************************************************************) + +open Tezos_micheline +open Protocol +open Alpha_context + +type localized_node + +type error += + | Wrong_stack_item of localized_node + | Wrong_stack of localized_node + | Wrong_other_contracts_item of localized_node + | Wrong_other_contracts of localized_node + | Wrong_extra_big_maps_item of localized_node + | Wrong_extra_big_maps of localized_node + | Invalid_address_for_smart_contract of string + +val print_localized_node_location : Format.formatter -> localized_node -> unit + +val print_localized_node : Format.formatter -> localized_node -> unit + +val parse_stack : + source:string -> + Micheline_parser.node -> + (Script.expr * Script.expr) list tzresult + +val parse_other_contracts : + source:string -> + Micheline_parser.node -> + RPC.Scripts.S.other_contract_description list tzresult + +val parse_extra_big_maps : + source:string -> + Micheline_parser.node -> + RPC.Scripts.S.extra_big_map_description list tzresult -- GitLab From f76cc28b9095a85c5aff036eb6793c6f5e55a4c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 20 Nov 2023 15:56:20 +0100 Subject: [PATCH 4/9] Client/Michelson/Parser: small factorization --- .../lib_client/michelson_v1_parser.ml | 24 ++++++++++++------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 09a8c7d5b710..53c1a13a1afd 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -86,18 +86,24 @@ let expand_all source ast errors = }, errors @ expansion_errors @ errs ) -let parse_toplevel ?check source = +type micheline_parser = Toplevel | Expression + +let parse micheline_parser ?check source = let tokens, lexing_errors = Micheline_parser.tokenize source in - let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in - let ast = - let start = min_point asts and stop = max_point asts in - Seq ({start; stop}, asts) + let ast, parsing_errors = + match micheline_parser with + | Toplevel -> + let asts, parsing_errors = + Micheline_parser.parse_toplevel ?check tokens + in + let start = min_point asts and stop = max_point asts in + (Seq ({start; stop}, asts), parsing_errors) + | Expression -> Micheline_parser.parse_expression ?check tokens in expand_all source ast (lexing_errors @ parsing_errors) -let parse_expression ?check source = - let tokens, lexing_errors = Micheline_parser.tokenize source in - let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in - expand_all source ast (lexing_errors @ parsing_errors) +let parse_toplevel = parse Toplevel + +let parse_expression = parse Expression let expand_all ~source ~original = expand_all source original [] -- GitLab From a989ab9f33a6ca030dff0a4f12fd59fa1bf659e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 10 Nov 2023 14:07:43 +0100 Subject: [PATCH 5/9] Client/Michelson/Parsing: expand with string prims This commit gives access to the intermediate result between macro expansion and recognition of primitives in the Michelson parser. --- .../lib_client/michelson_v1_parser.ml | 56 ++++++++++++------- .../lib_client/michelson_v1_parser.mli | 20 +++++-- .../lib_client/michelson_v1_stack.ml | 4 +- .../test/test_michelson_v1_macros.ml | 4 +- 4 files changed, 58 insertions(+), 26 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 53c1a13a1afd..ed9b0fb4d6bf 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -28,14 +28,16 @@ open Tezos_micheline open Micheline_parser open Micheline -type parsed = { +type 'prim parser_result = { source : string; unexpanded : string canonical; - expanded : Michelson_v1_primitives.prim canonical; + expanded : 'prim canonical; expansion_table : (int * (Micheline_parser.location * int list)) list; unexpansion_table : (int * int) list; } +type parsed = Michelson_v1_primitives.prim parser_result + let compare_parsed = Stdlib.compare (* Unexpanded toplevel expression should be a sequence *) @@ -71,24 +73,26 @@ let expand_all source ast errors = | Ok v -> v | Error () -> invalid_arg "Michelson_v1_parser.expand_all" in - match Michelson_v1_primitives.prims_of_strings expanded with - | Ok expanded -> - ( {source; unexpanded; expanded; expansion_table; unexpansion_table}, - errors @ expansion_errors ) + ( {source; unexpanded; expanded; expansion_table; unexpansion_table}, + errors @ expansion_errors ) + +let expand_all_and_recognize_prims source ast errors = + let parsed, errors = expand_all source ast errors in + match Michelson_v1_primitives.prims_of_strings parsed.expanded with + | Ok expanded -> ({parsed with expanded}, errors) | Error errs -> let errs = Environment.wrap_tztrace errs in - ( { - source; - unexpanded; - expanded = Micheline.strip_locations (Seq ((), [])); - expansion_table; - unexpansion_table; - }, - errors @ expansion_errors @ errs ) + let expanded = Micheline.strip_locations (Seq ((), [])) in + ({parsed with expanded}, errors @ errs) type micheline_parser = Toplevel | Expression -let parse micheline_parser ?check source = +type 'prim prim_type = + | Michelson_prim : Michelson_v1_primitives.prim prim_type + | String : string prim_type + +let parse (type prim) micheline_parser (prim_type : prim prim_type) ?check + source = let tokens, lexing_errors = Micheline_parser.tokenize source in let ast, parsing_errors = match micheline_parser with @@ -100,10 +104,24 @@ let parse micheline_parser ?check source = (Seq ({start; stop}, asts), parsing_errors) | Expression -> Micheline_parser.parse_expression ?check tokens in - expand_all source ast (lexing_errors @ parsing_errors) + let expand : + string -> + (location, string) Micheline.node -> + error trace -> + prim parser_result Micheline_parser.parsing_result = + match prim_type with + | Michelson_prim -> expand_all_and_recognize_prims + | String -> expand_all + in + expand source ast (lexing_errors @ parsing_errors) + +let parse_toplevel = parse Toplevel Michelson_prim + +let expand_toplevel = parse Toplevel String -let parse_toplevel = parse Toplevel +let parse_expression = parse Expression Michelson_prim -let parse_expression = parse Expression +let expand_expression = parse Expression String -let expand_all ~source ~original = expand_all source original [] +let expand_all_and_recognize_prims ~source ~original = + expand_all_and_recognize_prims source original [] diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.mli b/src/proto_alpha/lib_client/michelson_v1_parser.mli index 6aa29676741a..5f547e845439 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.mli +++ b/src/proto_alpha/lib_client/michelson_v1_parser.mli @@ -24,15 +24,15 @@ (*****************************************************************************) open Protocol -open Alpha_context open Tezos_micheline (** The result of parsing and expanding a Michelson V1 script or data. *) -type parsed = { +type 'prim parser_result = { source : string; (** The original source code. *) unexpanded : string Micheline.canonical; (** Original expression with macros. *) - expanded : Script.expr; (** Expression with macros fully expanded. *) + expanded : 'prim Micheline.canonical; + (** Expression with macros fully expanded. *) expansion_table : (int * (Micheline_parser.location * int list)) list; (** Associates unexpanded nodes to their parsing locations and the nodes expanded from it in the expanded expression. *) @@ -41,15 +41,27 @@ type parsed = { expression. *) } +type parsed = Michelson_v1_primitives.prim parser_result + val compare_parsed : parsed -> parsed -> int val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result +(** Same as [parse_toplevel] but skips the final step (recognizing the + primitives). *) +val expand_toplevel : + ?check:bool -> string -> string parser_result Micheline_parser.parsing_result + val parse_expression : ?check:bool -> string -> parsed Micheline_parser.parsing_result -val expand_all : +(** Same as [parse_expression] but skips the final step (recognizing the + primitives). *) +val expand_expression : + ?check:bool -> string -> string parser_result Micheline_parser.parsing_result + +val expand_all_and_recognize_prims : source:string -> original:Micheline_parser.node -> parsed Micheline_parser.parsing_result diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index c9422c170627..e90bc29e648d 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -195,7 +195,9 @@ let () = let parse_expression ~source (node : Micheline_parser.node) : Script.expr tzresult = let open Result_syntax in - let parsing_result = Michelson_v1_parser.expand_all ~source ~original:node in + let parsing_result = + Michelson_v1_parser.expand_all_and_recognize_prims ~source ~original:node + in let* parsed = Micheline_parser.no_parsing_error parsing_result in return parsed.expanded diff --git a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml index 7e03a4699232..b78f5e734f6b 100644 --- a/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml @@ -49,7 +49,7 @@ let assert_expands (expanded : (Micheline_parser.location, string) Micheline.node) = let {Michelson_v1_parser.expanded = expansion; _}, errors = let source = to_string (Micheline.strip_locations original) in - Michelson_v1_parser.expand_all ~source ~original + Michelson_v1_parser.expand_all_and_recognize_prims ~source ~original in match errors with | [] -> @@ -713,7 +713,7 @@ let test_map_cdadr () = let assert_unexpansion original ex = let {Michelson_v1_parser.expanded; _}, errors = let source = to_string (Micheline.strip_locations original) in - Michelson_v1_parser.expand_all ~source ~original + Michelson_v1_parser.expand_all_and_recognize_prims ~source ~original in let unparse = Michelson_v1_printer.unparse_expression expanded in match errors with -- GitLab From 1cb72306cebe4c0177fe4c97572d261061c02d80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 17 Nov 2023 14:44:51 +0100 Subject: [PATCH 6/9] Client/Michelson/Stacks: use locations in errors --- .../lib_client/michelson_v1_stack.ml | 37 +++++++++++++------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index e90bc29e648d..a213d8cff373 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -92,8 +92,10 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for an item in a typed stack. Expected: Stack_elt \ - ; got %a." + "%a,@ Unexpected format for an item in a typed stack. Expected: \ + Stack_elt ; got %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding @@ -107,8 +109,10 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for a typed stack. Expected a sequence of Stack_elt \ - ; got %a." + "%a,@ Unexpected format for a typed stack. Expected a sequence of \ + Stack_elt ; got %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding @@ -122,8 +126,10 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for an item in a description of other contracts. \ - Expected: Contract
; got %a." + "%a,@ Unexpected format for an item in a description of other \ + contracts. Expected: Contract
; got %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding @@ -137,8 +143,10 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for a description of other contracts. Expected a \ - sequence of Contract
; got %a." + "%a,@ Unexpected format for a description of other contracts. Expected \ + a sequence of Contract
; got %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding @@ -152,8 +160,11 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for an item in a description of extra big maps. \ - Expected: Big_map ; got %a." + "%a,@ Unexpected format for an item in a description of extra big \ + maps. Expected: Big_map ; \ + got %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding @@ -167,9 +178,11 @@ let () = ~pp:(fun ppf node -> Format.fprintf ppf - "Unexpected format for a description of extra big maps. Expected a \ - sequence of Big_map ; got \ + "%a,@ Unexpected format for a description of extra big maps. Expected \ + a sequence of Big_map ; got \ %a." + print_localized_node_location + node print_localized_node node) localized_node_encoding -- GitLab From bf904c8af5c21fc515b509eef58401903e1cacc6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Mon, 20 Nov 2023 22:30:01 +0100 Subject: [PATCH 7/9] Tezt: reset regression traces Generated with dune exec tezt/tests/main.exe -- alpha --file tezt/tests/normalize.ml --reset-regressions --- ...ha- Test Michelson stack normalization.out | 40 +++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/tezt/tests/expected/normalize.ml/Alpha- Test Michelson stack normalization.out b/tezt/tests/expected/normalize.ml/Alpha- Test Michelson stack normalization.out index 73dc5219be36..3f4caec3f3b5 100644 --- a/tezt/tests/expected/normalize.ml/Alpha- Test Michelson stack normalization.out +++ b/tezt/tests/expected/normalize.ml/Alpha- Test Michelson stack normalization.out @@ -133,16 +133,21 @@ Global options (must come before the command): ./octez-client --mode mockup normalize stack 0 Error: + At line 1 characters 0 to 1, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got 0. ./octez-client --mode mockup normalize stack '{Stack_elt}' Error: + At line 1 characters 0 to 11, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt }. + At line 1 characters 1 to 10, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack '{Stack_elt nat}' Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat }. + At line 1 characters 1 to 14, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat. ./octez-client --mode mockup normalize stack '{Stack_elt 0 nat}' @@ -152,16 +157,21 @@ Fatal error: ./octez-client --mode mockup normalize stack '{Stack_elt nat 0 1}' Error: + At line 1 characters 0 to 19, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 1 }. + At line 1 characters 1 to 18, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat 0 1. ./octez-client --mode mockup normalize stack 'Stack_elt nat 0' Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got Stack_elt nat 0. ./octez-client --mode mockup normalize stack '{Stack_elt nat 0; Stack_elt}' Error: + At line 1 characters 0 to 28, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 ; Stack_elt }. + At line 1 characters 18 to 27, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack --unparsing-mode Readable @@ -238,16 +248,21 @@ Global options (must come before the command): ./octez-client --mode mockup normalize stack 0 --unparsing-mode Readable Error: + At line 1 characters 0 to 1, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got 0. ./octez-client --mode mockup normalize stack '{Stack_elt}' --unparsing-mode Readable Error: + At line 1 characters 0 to 11, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt }. + At line 1 characters 1 to 10, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack '{Stack_elt nat}' --unparsing-mode Readable Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat }. + At line 1 characters 1 to 14, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat. ./octez-client --mode mockup normalize stack '{Stack_elt 0 nat}' --unparsing-mode Readable @@ -257,16 +272,21 @@ Fatal error: ./octez-client --mode mockup normalize stack '{Stack_elt nat 0 1}' --unparsing-mode Readable Error: + At line 1 characters 0 to 19, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 1 }. + At line 1 characters 1 to 18, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat 0 1. ./octez-client --mode mockup normalize stack 'Stack_elt nat 0' --unparsing-mode Readable Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got Stack_elt nat 0. ./octez-client --mode mockup normalize stack '{Stack_elt nat 0; Stack_elt}' --unparsing-mode Readable Error: + At line 1 characters 0 to 28, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 ; Stack_elt }. + At line 1 characters 18 to 27, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack --unparsing-mode Optimized @@ -343,16 +363,21 @@ Global options (must come before the command): ./octez-client --mode mockup normalize stack 0 --unparsing-mode Optimized Error: + At line 1 characters 0 to 1, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got 0. ./octez-client --mode mockup normalize stack '{Stack_elt}' --unparsing-mode Optimized Error: + At line 1 characters 0 to 11, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt }. + At line 1 characters 1 to 10, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack '{Stack_elt nat}' --unparsing-mode Optimized Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat }. + At line 1 characters 1 to 14, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat. ./octez-client --mode mockup normalize stack '{Stack_elt 0 nat}' --unparsing-mode Optimized @@ -362,16 +387,21 @@ Fatal error: ./octez-client --mode mockup normalize stack '{Stack_elt nat 0 1}' --unparsing-mode Optimized Error: + At line 1 characters 0 to 19, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 1 }. + At line 1 characters 1 to 18, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat 0 1. ./octez-client --mode mockup normalize stack 'Stack_elt nat 0' --unparsing-mode Optimized Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got Stack_elt nat 0. ./octez-client --mode mockup normalize stack '{Stack_elt nat 0; Stack_elt}' --unparsing-mode Optimized Error: + At line 1 characters 0 to 28, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 ; Stack_elt }. + At line 1 characters 18 to 27, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack --unparsing-mode Optimized_legacy @@ -448,16 +478,21 @@ Global options (must come before the command): ./octez-client --mode mockup normalize stack 0 --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 1, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got 0. ./octez-client --mode mockup normalize stack '{Stack_elt}' --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 11, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt }. + At line 1 characters 1 to 10, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. ./octez-client --mode mockup normalize stack '{Stack_elt nat}' --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat }. + At line 1 characters 1 to 14, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat. ./octez-client --mode mockup normalize stack '{Stack_elt 0 nat}' --unparsing-mode Optimized_legacy @@ -467,14 +502,19 @@ Fatal error: ./octez-client --mode mockup normalize stack '{Stack_elt nat 0 1}' --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 19, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 1 }. + At line 1 characters 1 to 18, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt nat 0 1. ./octez-client --mode mockup normalize stack 'Stack_elt nat 0' --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 15, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got Stack_elt nat 0. ./octez-client --mode mockup normalize stack '{Stack_elt nat 0; Stack_elt}' --unparsing-mode Optimized_legacy Error: + At line 1 characters 0 to 28, Unexpected format for a typed stack. Expected a sequence of Stack_elt ; got { Stack_elt nat 0 ; Stack_elt }. + At line 1 characters 18 to 27, Unexpected format for an item in a typed stack. Expected: Stack_elt ; got Stack_elt. -- GitLab From 5835ccbee236835b5b90bdd704bc00e1bab34358 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Fri, 17 Nov 2023 14:46:05 +0100 Subject: [PATCH 8/9] Client/Michelson/Stacks: expand macros before parsing stacks This commit moves the macro-expansion phase of parsing stacks (and other_contracts and extra_big_maps) from Michelson_v1_stack to Client_proto_args. This makes the corresponding Clic parameters behave more similarly to the ones used for other commands which is needed to better integrate them with the rest of the client. --- .../lib_client/client_proto_args.ml | 17 +- .../lib_client/client_proto_args.mli | 2 +- .../lib_client/michelson_v1_stack.ml | 150 ++++++++++-------- .../lib_client/michelson_v1_stack.mli | 12 +- .../client_proto_programs_commands.ml | 12 +- 5 files changed, 98 insertions(+), 95 deletions(-) diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index b89fc2d23c41..43379607b6cc 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -245,14 +245,7 @@ let binary_encoded_parameter ~name encoding = let parse_micheline_parameter source = Lwt.return @@ Tezos_micheline.Micheline_parser.no_parsing_error - @@ - let tokens, lexing_errors = - Tezos_micheline.Micheline_parser.tokenize source - in - let ast, parsing_errors = - Tezos_micheline.Micheline_parser.parse_expression tokens - in - ((ast, source), lexing_errors @ parsing_errors) + @@ Michelson_v1_parser.expand_expression source let micheline_parameter = Tezos_clic.parameter (fun (_ : full) source -> @@ -273,8 +266,8 @@ let init_arg = let other_contracts_parameter = Tezos_clic.parameter (fun _ source -> let open Lwt_result_syntax in - let* micheline, source = parse_micheline_parameter source in - let*? l = Michelson_v1_stack.parse_other_contracts ~source micheline in + let* parsed = parse_micheline_parameter source in + let*? l = Michelson_v1_stack.parse_other_contracts parsed in return l) let other_contracts_arg = @@ -288,8 +281,8 @@ let other_contracts_arg = let extra_big_maps_parameter = Tezos_clic.parameter (fun _ source -> let open Lwt_result_syntax in - let* micheline, source = parse_micheline_parameter source in - let*? l = Michelson_v1_stack.parse_extra_big_maps ~source micheline in + let* parsed = parse_micheline_parameter source in + let*? l = Michelson_v1_stack.parse_extra_big_maps parsed in return l) let extra_big_maps_arg = diff --git a/src/proto_alpha/lib_client/client_proto_args.mli b/src/proto_alpha/lib_client/client_proto_args.mli index 2d9e700bda64..efe27789217f 100644 --- a/src/proto_alpha/lib_client/client_proto_args.mli +++ b/src/proto_alpha/lib_client/client_proto_args.mli @@ -219,7 +219,7 @@ val raw_level_param : (Raw_level.t -> 'a, 'b) Tezos_clic.params val micheline_parameter : - (Tezos_micheline.Micheline_parser.node * string, full) Tezos_clic.parameter + (string Michelson_v1_parser.parser_result, full) Tezos_clic.parameter val unparsing_mode_arg : default:string -> (Script_ir_unparser.unparsing_mode, full) Tezos_clic.arg diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index a213d8cff373..9962c9690bab 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -28,50 +28,59 @@ open Protocol open Alpha_context type localized_node = { - loc : Micheline_parser.location; - node : Micheline_printer.node; + parser_loc : Micheline_parser.location option; + canonical_loc : Micheline.canonical_location; + node : string Micheline.canonical; } let print_localized_node_location fmt localized_node = - Format.fprintf - fmt - "%s" - (Format.kasprintf - String.capitalize_ascii - "%a" - Micheline_parser.print_location - localized_node.loc) + match localized_node.parser_loc with + | Some parser_loc -> + Format.fprintf + fmt + "%s" + (Format.kasprintf + String.capitalize_ascii + "%a" + Micheline_parser.print_location + parser_loc) + | None -> Format.fprintf fmt "At position %d" localized_node.canonical_loc let print_localized_node fmt localized_node = - Micheline_printer.print_expr_unwrapped fmt localized_node.node - -let localize_node (n : (Micheline_parser.location, string) Micheline.node) : - localized_node = - { - loc = Micheline.location n; - node = Micheline_printer.printable Fun.id (Micheline.strip_locations n); - } + Micheline_printer.print_expr_unwrapped + fmt + (Micheline_printer.printable Fun.id localized_node.node) -let micheline_printer_location_encoding : - Micheline_printer.location Data_encoding.encoding = - let open Data_encoding in - conv - (fun loc -> loc.Micheline_printer.comment) - (fun comment -> {comment}) - (option string) +let localize_node ~(parsed : string Michelson_v1_parser.parser_result) + (n : (Micheline.canonical_location, string) Micheline.node) : localized_node + = + let canonical_loc = Micheline.location n in + let parser_loc = + let open Option_syntax in + let* oloc = + List.assoc ~equal:Int.equal canonical_loc parsed.unexpansion_table + in + let+ ploc, _ = List.assoc ~equal:Int.equal oloc parsed.expansion_table in + ploc + in + {parser_loc; canonical_loc; node = Micheline.strip_locations n} let localized_node_encoding : localized_node Data_encoding.t = Data_encoding.( conv - (fun {loc; node} -> (loc, node)) - (fun (loc, node) -> {loc; node}) - (obj2 - (req "location" Micheline_parser.location_encoding) + (fun {parser_loc; canonical_loc; node} -> + (parser_loc, canonical_loc, node)) + (fun (parser_loc, canonical_loc, node) -> + {parser_loc; canonical_loc; node}) + (obj3 + (req "parser_location" (option Micheline_parser.location_encoding)) + (req + "canonical_location" + Micheline_encoding.canonical_location_encoding) (req "node" - (Micheline_encoding.table_encoding - ~variant:"" - micheline_printer_location_encoding + (Micheline_encoding.canonical_encoding + ~variant:"alpha_client" Data_encoding.string)))) type error += @@ -205,71 +214,76 @@ let () = (function Invalid_address_for_smart_contract str -> Some str | _ -> None) (fun str -> Invalid_address_for_smart_contract str) -let parse_expression ~source (node : Micheline_parser.node) : - Script.expr tzresult = - let open Result_syntax in - let parsing_result = - Michelson_v1_parser.expand_all_and_recognize_prims ~source ~original:node - in - let* parsed = Micheline_parser.no_parsing_error parsing_result in - return parsed.expanded +let parse_expression (node : (_, string) Micheline.node) = + Environment.wrap_tzresult + @@ Michelson_v1_primitives.prims_of_strings (Micheline.strip_locations node) -let parse_stack_item ~source = +let parse_stack_item ~parsed = let open Result_syntax in function | Micheline.Prim (_loc, "Stack_elt", [ty; v], _annot) -> - let* ty = parse_expression ~source ty in - let* v = parse_expression ~source v in + let* ty = parse_expression ty in + let* v = parse_expression v in return (ty, v) - | e -> tzfail (Wrong_stack_item (localize_node e)) + | e -> tzfail (Wrong_stack_item (localize_node ~parsed e)) -let parse_other_contract_item ~source = +let parse_other_contract_item ~parsed = let open Result_syntax in function | Micheline.Prim (_loc, "Contract", [address; ty], _annot) as e -> - let* address = parse_expression ~source address in + let* address = parse_expression address in let* address = match Micheline.root address with | Micheline.String (_loc, s) -> ( match Environment.Base58.decode s with | Some (Contract_hash.Data h) -> return h | Some _ | None -> tzfail (Invalid_address_for_smart_contract s)) - | _ -> tzfail (Wrong_other_contracts_item (localize_node e)) + | _ -> tzfail (Wrong_other_contracts_item (localize_node ~parsed e)) in - let* ty = parse_expression ~source ty in + let* ty = parse_expression ty in return RPC.Scripts.S.{address; ty} - | e -> tzfail (Wrong_other_contracts_item (localize_node e)) + | e -> tzfail (Wrong_other_contracts_item (localize_node ~parsed e)) -let parse_extra_big_map_item ~source = +let parse_extra_big_map_item ~parsed = let open Result_syntax in function | Micheline.Prim (_loc, "Big_map", [id; kty; vty; items], _annot) as e -> - let* id = parse_expression ~source id in + let* id = parse_expression id in let* id = match Micheline.root id with | Micheline.Int (_loc, id) -> return (Big_map.Id.parse_z id) - | _ -> tzfail (Wrong_other_contracts_item (localize_node e)) + | _ -> tzfail (Wrong_other_contracts_item (localize_node ~parsed e)) in - let* kty = parse_expression ~source kty in - let* vty = parse_expression ~source vty in - let* items = parse_expression ~source items in + let* kty = parse_expression kty in + let* vty = parse_expression vty in + let* items = parse_expression items in return RPC.Scripts.S.{id; kty; vty; items} - | e -> tzfail (Wrong_extra_big_maps_item (localize_node e)) + | e -> tzfail (Wrong_extra_big_maps_item (localize_node ~parsed e)) -let parse_stack ~source = function +let parse_stack ?node (parsed : string Michelson_v1_parser.parser_result) = + let node = Option.value ~default:(Micheline.root parsed.expanded) node in + match node with | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> Wrong_stack (localize_node e)) - @@ List.map_e (parse_stack_item ~source) l - | e -> Result_syntax.tzfail (Wrong_stack (localize_node e)) + record_trace_eval (fun () -> Wrong_stack (localize_node ~parsed e)) + @@ List.map_e (parse_stack_item ~parsed) l + | e -> Result_syntax.tzfail (Wrong_stack (localize_node ~parsed e)) -let parse_other_contracts ~source = function +let parse_other_contracts ?node + (parsed : string Michelson_v1_parser.parser_result) = + let node = Option.value ~default:(Micheline.root parsed.expanded) node in + match node with | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> Wrong_other_contracts (localize_node e)) - @@ List.map_e (parse_other_contract_item ~source) l - | e -> Result_syntax.tzfail (Wrong_other_contracts (localize_node e)) + record_trace_eval (fun () -> + Wrong_other_contracts (localize_node ~parsed e)) + @@ List.map_e (parse_other_contract_item ~parsed) l + | e -> Result_syntax.tzfail (Wrong_other_contracts (localize_node ~parsed e)) -let parse_extra_big_maps ~source = function +let parse_extra_big_maps ?node + (parsed : string Michelson_v1_parser.parser_result) = + let node = Option.value ~default:(Micheline.root parsed.expanded) node in + match node with | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> Wrong_extra_big_maps (localize_node e)) - @@ List.map_e (parse_extra_big_map_item ~source) l - | e -> Result_syntax.tzfail (Wrong_extra_big_maps (localize_node e)) + record_trace_eval (fun () -> + Wrong_extra_big_maps (localize_node ~parsed e)) + @@ List.map_e (parse_extra_big_map_item ~parsed) l + | e -> Result_syntax.tzfail (Wrong_extra_big_maps (localize_node ~parsed e)) diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.mli b/src/proto_alpha/lib_client/michelson_v1_stack.mli index aadada2b2b29..7501aa09f6e1 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.mli +++ b/src/proto_alpha/lib_client/michelson_v1_stack.mli @@ -25,16 +25,16 @@ val print_localized_node_location : Format.formatter -> localized_node -> unit val print_localized_node : Format.formatter -> localized_node -> unit val parse_stack : - source:string -> - Micheline_parser.node -> + ?node:(Micheline.canonical_location, string) Micheline.node -> + string Michelson_v1_parser.parser_result -> (Script.expr * Script.expr) list tzresult val parse_other_contracts : - source:string -> - Micheline_parser.node -> + ?node:(Micheline.canonical_location, string) Micheline.node -> + string Michelson_v1_parser.parser_result -> RPC.Scripts.S.other_contract_description list tzresult val parse_extra_big_maps : - source:string -> - Micheline_parser.node -> + ?node:(Micheline.canonical_location, string) Micheline.node -> + string Michelson_v1_parser.parser_result -> RPC.Scripts.S.extra_big_map_description list tzresult diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 27f6370be44b..9eb52904092f 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -391,13 +391,11 @@ let commands () = extra_big_maps, legacy ) program - (stack, stack_source) + stack cctxt -> let open Lwt_result_syntax in let*? program = Micheline_parser.no_parsing_error program in - let*? stack = - Michelson_v1_stack.parse_stack ~source:stack_source stack - in + let*? stack = Michelson_v1_stack.parse_stack stack in let*! res = run_instr cctxt @@ -855,11 +853,9 @@ let commands () = other_contracts_arg extra_big_maps_arg) (prefixes ["normalize"; "stack"] @@ stack_param () @@ stop) - (fun (unparsing_mode, legacy, other_contracts, extra_big_maps) - (stack, source) - cctxt -> + (fun (unparsing_mode, legacy, other_contracts, extra_big_maps) stack cctxt -> let open Lwt_result_syntax in - let*? stack = Michelson_v1_stack.parse_stack ~source stack in + let*? stack = Michelson_v1_stack.parse_stack stack in let*! r = Plugin.RPC.Scripts.normalize_stack cctxt -- GitLab From 31471e1e106dd2e074eefde49b46c21d03d8d94b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Cauderlier?= Date: Thu, 23 Nov 2023 11:45:49 +0100 Subject: [PATCH 9/9] Client/Michelson/Stacks: factorize sequence parsing This commit factorizes the three functions parsing sequences: parse_stack, parse_other_contracts, and parse_extra_big_maps. --- .../lib_client/michelson_v1_stack.ml | 48 ++++++++++--------- 1 file changed, 25 insertions(+), 23 deletions(-) diff --git a/src/proto_alpha/lib_client/michelson_v1_stack.ml b/src/proto_alpha/lib_client/michelson_v1_stack.ml index 9962c9690bab..a8bf55830929 100644 --- a/src/proto_alpha/lib_client/michelson_v1_stack.ml +++ b/src/proto_alpha/lib_client/michelson_v1_stack.ml @@ -260,30 +260,32 @@ let parse_extra_big_map_item ~parsed = return RPC.Scripts.S.{id; kty; vty; items} | e -> tzfail (Wrong_extra_big_maps_item (localize_node ~parsed e)) -let parse_stack ?node (parsed : string Michelson_v1_parser.parser_result) = +let parse_sequence ?node ~(parsed : string Michelson_v1_parser.parser_result) + ~error parse_item = let node = Option.value ~default:(Micheline.root parsed.expanded) node in + let error () = error (localize_node ~parsed node) in match node with - | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> Wrong_stack (localize_node ~parsed e)) - @@ List.map_e (parse_stack_item ~parsed) l - | e -> Result_syntax.tzfail (Wrong_stack (localize_node ~parsed e)) + | Micheline.Seq (_loc, l) -> + record_trace_eval error @@ List.map_e (parse_item ~parsed) l + | _ -> Result_syntax.tzfail (error ()) -let parse_other_contracts ?node - (parsed : string Michelson_v1_parser.parser_result) = - let node = Option.value ~default:(Micheline.root parsed.expanded) node in - match node with - | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> - Wrong_other_contracts (localize_node ~parsed e)) - @@ List.map_e (parse_other_contract_item ~parsed) l - | e -> Result_syntax.tzfail (Wrong_other_contracts (localize_node ~parsed e)) +let parse_stack ?node parsed = + parse_sequence + ?node + ~parsed + ~error:(fun node -> Wrong_stack node) + parse_stack_item -let parse_extra_big_maps ?node - (parsed : string Michelson_v1_parser.parser_result) = - let node = Option.value ~default:(Micheline.root parsed.expanded) node in - match node with - | Micheline.Seq (_loc, l) as e -> - record_trace_eval (fun () -> - Wrong_extra_big_maps (localize_node ~parsed e)) - @@ List.map_e (parse_extra_big_map_item ~parsed) l - | e -> Result_syntax.tzfail (Wrong_extra_big_maps (localize_node ~parsed e)) +let parse_other_contracts ?node parsed = + parse_sequence + ?node + ~parsed + ~error:(fun node -> Wrong_other_contracts node) + parse_other_contract_item + +let parse_extra_big_maps ?node parsed = + parse_sequence + ?node + ~parsed + ~error:(fun node -> Wrong_extra_big_maps node) + parse_extra_big_map_item -- GitLab