From 76e70a2799b989d6793cefefbca5365c19515f0a Mon Sep 17 00:00:00 2001 From: Milo Davis Date: Fri, 1 Dec 2017 17:00:32 +0100 Subject: [PATCH] Michelson macros: annotations permitted and better error handling --- lib_embedded_client_alpha/michelson_macros.ml | 158 +++++++++++------- .../michelson_macros.mli | 27 +-- .../michelson_v1_parser.ml | 32 +++- .../src/michelson_v1_primitives.ml | 2 +- test/contracts/cadr_annotation.tz | 4 + test/contracts/macro_annotations.tz | 6 + test/contracts/map_car.tz | 4 + test/contracts/pair_macro.tz | 4 + test/contracts/set_caddaadr.tz | 2 +- test/contracts/set_car.tz | 2 +- test/contracts/set_cdr.tz | 2 +- test/contracts/unpair_macro.tz | 4 + 12 files changed, 164 insertions(+), 83 deletions(-) create mode 100644 test/contracts/cadr_annotation.tz create mode 100644 test/contracts/macro_annotations.tz create mode 100644 test/contracts/map_car.tz create mode 100644 test/contracts/pair_macro.tz create mode 100644 test/contracts/unpair_macro.tz diff --git a/lib_embedded_client_alpha/michelson_macros.ml b/lib_embedded_client_alpha/michelson_macros.ml index 6ef996a73..a217f4197 100644 --- a/lib_embedded_client_alpha/michelson_macros.ml +++ b/lib_embedded_client_alpha/michelson_macros.ml @@ -12,8 +12,11 @@ open Micheline type 'l node = ('l, string) Micheline.node +type error += Unexpected_macro_annotation of string +type error += Dip_expects_sequence + let expand_caddadr original = - match original with + ok @@ match original with | Prim (loc, str, [], annot) -> let len = String.length str in if len > 3 @@ -23,6 +26,7 @@ let expand_caddadr original = if i = 0 then Some (Seq (loc, acc, None)) else + let annot = if i = (String.length str - 2) then annot else None in match String.get str i with | 'A' -> parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc) | 'D' -> parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc) @@ -33,8 +37,8 @@ let expand_caddadr original = | _ -> None let expand_set_caddadr original = - match original with - | Prim (loc, str, [], None) -> + ok @@ match original with + | Prim (loc, str, [], annot) -> let len = String.length str in if len >= 7 && String.sub str 0 5 = "SET_C" @@ -73,14 +77,19 @@ let expand_set_caddadr original = let init = Seq (loc, [ Prim (loc, "CDR", [], None) ; - Prim (loc, "SWAP", [], None) ; + Prim (loc, "SWAP", [], annot) ; Prim (loc, "PAIR", [], None) ], None) in parse (len - 3) init | 'D' -> let init = Seq (loc, - [ Prim (loc, "CAR", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + (Prim (loc, "CAR", [], None)) :: + (let pair = Prim (loc, "PAIR", [], None) in + match annot with + | None -> [ pair ] + | Some _ -> [ Prim (loc, "SWAP", [], annot) ; + Prim (loc, "SWAP", [], None) ; + pair]), None) in parse (len - 3) init | _ -> None else @@ -89,7 +98,10 @@ let expand_set_caddadr original = let expand_map_caddadr original = match original with - | Prim (loc, str, [ Seq _ as code ], None) -> + | Prim (loc, str, [ Seq _ as code ], annot) -> + begin match annot with + | Some _ -> (error (Unexpected_macro_annotation str)) + | None -> ok () end >|? fun () -> let len = String.length str in if len >= 7 && String.sub str 0 5 = "MAP_C" @@ -129,9 +141,9 @@ let expand_map_caddadr original = Seq (loc, [ Prim (loc, "DUP", [], None) ; Prim (loc, "CDR", [], None) ; + Prim (loc, "DIP", + [ Seq (loc, [ Prim (loc, "CAR", [], None) ; code ], None) ], None) ; Prim (loc, "SWAP", [], None) ; - Prim (loc, "CAR", [], None) ; - code ; Prim (loc, "PAIR", [], None) ], None) in parse (len - 3) init | 'D' -> @@ -147,7 +159,7 @@ let expand_map_caddadr original = | _ -> None else None - | _ -> None + | _ -> ok None exception Not_a_roman @@ -165,7 +177,7 @@ let decimal_of_roman roman = | 'X' -> 10 | 'V' -> 5 | 'I' -> 1 - | _ -> raise Not_a_roman + | _ -> raise_notrace Not_a_roman in if Compare.Int.(n < !lastval) then arabic := !arabic - n @@ -176,7 +188,7 @@ let decimal_of_roman roman = let expand_dxiiivp original = match original with - | Prim (loc, str, [ arg ], None) -> + | Prim (loc, str, args, annot) -> let len = String.length str in if len > 3 && String.get str 0 = 'D' @@ -188,17 +200,19 @@ let expand_dxiiivp original = acc else make (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ], None)) in - Some (make depth arg) - with Not_a_roman -> None - else None - | _ -> None + (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ], None)) in + match args with + | [ Seq (_, _, _) as arg ] -> ok @@ Some (make depth arg) + | _ -> error Dip_expects_sequence + with Not_a_roman -> ok None + else ok None + | _ -> ok None exception Not_a_pair let expand_paaiair original = match original with - | Prim (loc, str, [], None) -> + | Prim (loc, str, [], annot) -> let len = String.length str in if len > 4 && String.get str 0 = 'P' @@ -209,25 +223,25 @@ let expand_paaiair original = acc else if String.get str i = 'I' && String.get str (i - 1) = 'A' then - parse (i - 2) (Prim (loc, "PAIR", [], None) :: acc) + parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else None) :: acc) else if String.get str i = 'A' then match acc with | [] -> - raise Not_a_pair + raise_notrace Not_a_pair | acc :: accs -> parse (i - 1) (Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None) :: accs) else - raise Not_a_pair in - Some (Seq (loc, parse (len - 2) [], None)) - with Not_a_pair -> None + raise_notrace Not_a_pair in + ok @@ Some (Seq (loc, parse (len - 2) [], None)) + with Not_a_pair -> ok None else - None - | _ -> None + ok None + | _ -> ok None let expand_unpaaiair original = - match original with + ok @@ match original with | Prim (loc, str, [], None) -> let len = String.length str in if len >= 6 @@ -252,7 +266,7 @@ let expand_unpaaiair original = else if String.get str i = 'A' then match acc with | [] -> - raise Not_a_pair + raise_notrace Not_a_pair | (Seq _ as acc) :: accs -> parse (i - 1) (Prim (loc, "DIP", [ acc ], None) :: accs) @@ -262,7 +276,7 @@ let expand_unpaaiair original = [ Seq (loc, [ acc ], None) ], None) :: accs) else - raise Not_a_pair in + raise_notrace Not_a_pair in Some (parse (len - 2) []) with Not_a_pair -> None else @@ -272,8 +286,8 @@ let expand_unpaaiair original = exception Not_a_dup let expand_duuuuup original = - match original with - | Prim (loc, str, [], None) -> + ok @@ match original with + | Prim (loc, str, [], annot) -> let len = String.length str in if len > 3 && String.get str 0 = 'D' @@ -287,15 +301,15 @@ let expand_duuuuup original = (Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ; Prim (loc, "SWAP", [], None) ], None)) else - raise Not_a_dup in - Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], None) ], None))) + raise_notrace Not_a_dup in + Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ], None))) with Not_a_dup -> None else None | _ -> None let expand_compare original = - match original with + ok @@ match original with | Prim (loc, "CMPEQ", [], None) -> Some (Seq (loc, [ Prim (loc, "COMPARE", [], None) ; Prim (loc, "EQ", [], None) ], None)) @@ -356,7 +370,7 @@ let expand_compare original = | Prim (loc, "IFGE", args, None) -> Some (Seq (loc, [ Prim (loc, "GE", [], None) ; Prim (loc, "IF", args, None) ], None)) - | _ -> None;; + | _ -> None let expand_asserts original = @@ -366,15 +380,15 @@ let expand_asserts original = [ Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ; Seq(loc, [], None) ] in match original with | Prim (loc, "ASSERT", [], None) -> - Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None)) + ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None)) | Prim (loc, "ASSERT_NONE", [], None) -> - Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None)) + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None)) | Prim (loc, "ASSERT_SOME", [], None) -> - Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None)) + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None)) | Prim (loc, "ASSERT_LEFT", [], None) -> - Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None)) + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None)) | Prim (loc, "ASSERT_RIGHT", [], None) -> - Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None)) + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None)) | Prim (loc, s, [], None) when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> begin @@ -382,41 +396,37 @@ let expand_asserts original = let remaining_prim = Prim(loc, remaining, [], None) in match remaining with | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> - Some (Seq (loc, [ remaining_prim ; - Prim (loc, "IF", fail_false loc, None) ], None)) + ok @@ Some (Seq (loc, [ remaining_prim ; + Prim (loc, "IF", fail_false loc, None) ], None)) | _ -> begin - match expand_compare remaining_prim with + expand_compare remaining_prim >|? function | None -> None | Some seq -> Some (Seq (loc, [ seq ; Prim (loc, "IF", fail_false loc, None) ], None)) end end - | _ -> None + | _ -> ok None let expand_if_some = function | Prim (loc, "IF_SOME", [ right ; left ], None) -> - Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None)) - | _ -> None + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None)) + | _ -> ok @@ None let expand_if_right = function | Prim (loc, "IF_RIGHT", [ right ; left ], None) -> - Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None)) - | _ -> None + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None)) + | _ -> ok @@ None let expand original = - let try_expansions expanders = - match - List.fold_left - (fun acc f -> - match acc with - | None -> f original - | Some rewritten -> Some rewritten) - None expanders with - | None -> original - | Some rewritten -> rewritten in + let rec try_expansions = function + | [] -> ok @@ original + | expander :: expanders -> + expander original >>? function + | None -> try_expansions expanders + | Some rewritten -> ok rewritten in try_expansions [ expand_caddadr ; expand_set_caddadr ; @@ -744,7 +754,7 @@ let unexpand_if_right = function | _ -> None let unexpand original = - let try_expansions unexpanders = + let try_unexpansions unexpanders = match List.fold_left (fun acc f -> @@ -754,7 +764,7 @@ let unexpand original = None unexpanders with | None -> original | Some rewritten -> rewritten in - try_expansions + try_unexpansions [ unexpand_asserts ; unexpand_caddadr ; unexpand_set_caddadr ; @@ -766,3 +776,33 @@ let unexpand original = unexpand_compare ; unexpand_if_some ; unexpand_if_right ] + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"unexpectedMacroAnnotation" + ~title:"Unexpected annotation" + ~description:"A macro had an annotation, but no annotation was permitted on this macro." + ~pp:(fun ppf -> + Format.fprintf ppf + "@[@[Unexpected annotation on instruction %s.@]@]") + (obj1 + (req "instrName" string)) + (function + | Unexpected_macro_annotation str -> Some str + | _ -> None) + (fun s -> Unexpected_macro_annotation s) ; + register_error_kind + `Permanent + ~id:"dipExpectsSequence" + ~title:"Dip instruction expects a sequence" + ~description:"A dip instruction expects a sequence, but a sequence was not provided" + ~pp:(fun ppf () -> + Format.fprintf ppf + "@[@[DIP instructionf expects a sequence, but did not receive one.@]@]") + empty + (function + | Dip_expects_sequence -> Some () + | _ -> None) + (fun () -> Dip_expects_sequence) diff --git a/lib_embedded_client_alpha/michelson_macros.mli b/lib_embedded_client_alpha/michelson_macros.mli index a5cdde6a7..3df14effa 100644 --- a/lib_embedded_client_alpha/michelson_macros.mli +++ b/lib_embedded_client_alpha/michelson_macros.mli @@ -11,19 +11,22 @@ open Tezos_micheline type 'l node = ('l, string) Micheline.node -val expand : 'l node -> 'l node +type error += Unexpected_macro_annotation of string +type error += Dip_expects_sequence -val expand_caddadr : 'l node -> 'l node option -val expand_set_caddadr : 'l node -> 'l node option -val expand_map_caddadr : 'l node -> 'l node option -val expand_dxiiivp : 'l node -> 'l node option -val expand_paaiair : 'l node -> 'l node option -val expand_duuuuup : 'l node -> 'l node option -val expand_compare : 'l node -> 'l node option -val expand_asserts : 'l node -> 'l node option -val expand_unpaaiair : 'l node -> 'l node option -val expand_if_some : 'l node -> 'l node option -val expand_if_right : 'l node -> 'l node option +val expand : 'l node -> 'l node tzresult + +val expand_caddadr : 'l node -> 'l node option tzresult +val expand_set_caddadr : 'l node -> 'l node option tzresult +val expand_map_caddadr : 'l node -> 'l node option tzresult +val expand_dxiiivp : 'l node -> 'l node option tzresult +val expand_paaiair : 'l node -> 'l node option tzresult +val expand_duuuuup : 'l node -> 'l node option tzresult +val expand_compare : 'l node -> 'l node option tzresult +val expand_asserts : 'l node -> 'l node option tzresult +val expand_unpaaiair : 'l node -> 'l node option tzresult +val expand_if_some : 'l node -> 'l node option tzresult +val expand_if_right : 'l node -> 'l node option tzresult val unexpand : 'l node -> 'l node diff --git a/lib_embedded_client_alpha/michelson_v1_parser.ml b/lib_embedded_client_alpha/michelson_v1_parser.ml index 41cb01dfb..76336ee75 100644 --- a/lib_embedded_client_alpha/michelson_v1_parser.ml +++ b/lib_embedded_client_alpha/michelson_v1_parser.ml @@ -18,18 +18,34 @@ type parsed = expansion_table : (int * (Micheline_parser.location * int list)) list ; unexpansion_table : (int * int) list } +(* Unexpanded toplevel expression should be a sequence *) let expand_all source ast errors = let unexpanded, loc_table = extract_locations ast in + let rec error_map (expanded, errors) f = function + | [] -> (List.rev expanded, List.rev errors) + | hd :: tl -> + let (new_expanded, new_errors) = f hd in + error_map + (new_expanded :: expanded, List.rev_append new_errors errors) + f tl in + let error_map = error_map ([], []) in let rec expand expr = match Michelson_macros.expand expr with - | Seq (loc, items, annot) -> - Seq (loc, List.map expand items, annot) - | Prim (loc, name, args, annot) -> - Prim (loc, name, List.map expand args, annot) - | Int _ | String _ as atom -> atom in + | Ok expanded -> + begin + match expanded with + | Seq (loc, items, annot) -> + let items, errors = error_map expand items in + (Seq (loc, items, annot), errors) + | Prim (loc, name, args, annot) -> + let args, errors = error_map expand args in + (Prim (loc, name, args, annot), errors) + | Int _ | String _ as atom -> (atom, []) end + | Error errors -> (expr, errors) in + let expanded, expansion_errors = expand (root unexpanded) in let expanded, unexpansion_table = - extract_locations (expand (root unexpanded)) in + extract_locations expanded in let expansion_table = let sorted = List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in @@ -54,12 +70,12 @@ let expand_all source ast errors = | Ok expanded -> { source ; unexpanded ; expanded ; expansion_table ; unexpansion_table }, - errors + errors @ expansion_errors | Error errs -> { source ; unexpanded ; expanded = Micheline.strip_locations (Seq ((), [], None)) ; expansion_table ; unexpansion_table }, - errs @ errors + errs @ errors @ expansion_errors let parse_toplevel ?check source = let tokens, lexing_errors = Micheline_parser.tokenize source in diff --git a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml index 5b5be9c9b..c10368e23 100644 --- a/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml +++ b/lib_embedded_protocol_alpha/src/michelson_v1_primitives.ml @@ -609,7 +609,7 @@ let () = ~title: "Unknown primitive name (typechecking error)" ~description: "In a script or data expression, a primitive was unknown." - ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) + ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s.@," n) Data_encoding.(obj1 (req "wrongPrimitiveName" string)) (function | Unknown_primitive_name got -> Some got diff --git a/test/contracts/cadr_annotation.tz b/test/contracts/cadr_annotation.tz new file mode 100644 index 000000000..43afa55d9 --- /dev/null +++ b/test/contracts/cadr_annotation.tz @@ -0,0 +1,4 @@ +parameter (pair (pair unit (string @no_name)) bool); +storage unit; +return unit; +code { CAR @name; CADR @second_name; DROP; UNIT; UNIT; PAIR } diff --git a/test/contracts/macro_annotations.tz b/test/contracts/macro_annotations.tz new file mode 100644 index 000000000..fdc374061 --- /dev/null +++ b/test/contracts/macro_annotations.tz @@ -0,0 +1,6 @@ +return unit; +parameter unit; +storage unit; +code { PUSH unit Unit ; + DUUP @truc ; + DROP ; DROP } diff --git a/test/contracts/map_car.tz b/test/contracts/map_car.tz new file mode 100644 index 000000000..6d8dab481 --- /dev/null +++ b/test/contracts/map_car.tz @@ -0,0 +1,4 @@ +parameter bool; +storage (pair bool nat); +return unit; +code { DUP; CAR; DIP{CDR}; SWAP; MAP_CAR { AND } ; UNIT; PAIR }; diff --git a/test/contracts/pair_macro.tz b/test/contracts/pair_macro.tz new file mode 100644 index 000000000..ab9246e17 --- /dev/null +++ b/test/contracts/pair_macro.tz @@ -0,0 +1,4 @@ +parameter unit; +return unit; +storage unit; +code { UNIT; UNIT; UNIT; UNIT; UNIT; PAIAAIAIAIR @name; DROP} diff --git a/test/contracts/set_caddaadr.tz b/test/contracts/set_caddaadr.tz index d2be87afa..8a55c4109 100644 --- a/test/contracts/set_caddaadr.tz +++ b/test/contracts/set_caddaadr.tz @@ -2,5 +2,5 @@ parameter tez; storage (pair (pair nat (pair nat (pair (pair (pair nat tez) nat) nat))) nat); return unit; code { DUP ; CAR ; SWAP ; CDR ; - SET_CADDAADR ; + SET_CADDAADR @annot ; UNIT ; PAIR }; diff --git a/test/contracts/set_car.tz b/test/contracts/set_car.tz index ed894a17a..4c0d24c77 100644 --- a/test/contracts/set_car.tz +++ b/test/contracts/set_car.tz @@ -1,4 +1,4 @@ parameter string; storage (pair string nat); return (pair string nat); -code {DUP; CDR; DIP{CAR}; SET_CAR; DUP; PAIR}; +code { DUP; CDR; DIP{CAR}; SET_CAR @hello; DUP; PAIR }; diff --git a/test/contracts/set_cdr.tz b/test/contracts/set_cdr.tz index c434b6793..549787cfd 100644 --- a/test/contracts/set_cdr.tz +++ b/test/contracts/set_cdr.tz @@ -1,4 +1,4 @@ parameter nat; storage (pair string nat); return (pair string nat); -code {DUP; CDR; DIP{CAR}; SET_CDR; DUP; PAIR}; +code { DUP; CDR; DIP{CAR}; SET_CDR @annot; DUP; PAIR }; diff --git a/test/contracts/unpair_macro.tz b/test/contracts/unpair_macro.tz new file mode 100644 index 000000000..12a4578df --- /dev/null +++ b/test/contracts/unpair_macro.tz @@ -0,0 +1,4 @@ +parameter unit; +storage unit; +return unit; +code { UNIT; UNIT; UNIT; UNIT; PAIAAIR; UNPAIAAIR; DROP; DROP; DROP; DROP }