From 3140f6e51def4bb614cc2dc64e99680e3c84de85 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Thu, 17 May 2018 19:37:25 +0200 Subject: [PATCH] Michelson: allow multiple annotations --- src/lib_micheline/micheline.ml | 102 ++-- src/lib_micheline/micheline.mli | 8 +- src/lib_micheline/micheline_parser.ml | 71 ++- src/lib_micheline/micheline_printer.ml | 34 +- .../sigs/v1/micheline.mli | 6 +- .../lib_baking/test/test_michelson_parser.ml | 265 ++++----- .../lib_client/michelson_v1_emacs.ml | 15 +- .../lib_client/michelson_v1_error_reporter.ml | 31 +- .../lib_client/michelson_v1_macros.ml | 563 +++++++++--------- .../lib_client/michelson_v1_parser.ml | 4 +- .../lib_client/michelson_v1_printer.ml | 8 +- src/proto_alpha/lib_protocol/src/apply.ml | 2 +- .../src/michelson_v1_primitives.ml | 8 +- .../lib_protocol/src/script_interpreter.ml | 6 +- .../lib_protocol/src/script_ir_translator.ml | 200 +++---- .../lib_protocol/src/script_ir_translator.mli | 2 +- .../lib_protocol/src/script_repr.ml | 12 +- .../lib_protocol/src/script_tc_errors.ml | 2 +- .../src/script_tc_errors_registration.ml | 8 +- .../lib_protocol/src/script_typed_ir.ml | 2 +- 20 files changed, 661 insertions(+), 688 deletions(-) diff --git a/src/lib_micheline/micheline.ml b/src/lib_micheline/micheline.ml index 5e0ca1e86..d0f6f2a98 100644 --- a/src/lib_micheline/micheline.ml +++ b/src/lib_micheline/micheline.ml @@ -10,8 +10,8 @@ type ('l, 'p) node = | Int of 'l * Z.t | String of 'l * string - | Prim of 'l * 'p * ('l, 'p) node list * string option - | Seq of 'l * ('l, 'p) node list * string option + | Prim of 'l * 'p * ('l, 'p) node list * string list + | Seq of 'l * ('l, 'p) node list type canonical_location = int @@ -32,14 +32,14 @@ let canonical_location_encoding = let location = function | Int (loc, _) -> loc | String (loc, _) -> loc - | Seq (loc, _, _) -> loc + | Seq (loc, _) -> loc | Prim (loc, _, _, _) -> loc -let annotation = function - | Int (_, _) -> None - | String (_, _) -> None - | Seq (_, _, annot) -> annot - | Prim (_, _, _, annot) -> annot +let annotations = function + | Int (_, _) -> [] + | String (_, _) -> [] + | Seq (_, _) -> [] + | Prim (_, _, _, annots) -> annots let root (Canonical expr) = expr @@ -53,10 +53,10 @@ let strip_locations root = Int (id, v) | String (_, v) -> String (id, v) - | Seq (_, seq, annot) -> - Seq (id, List.map strip_locations seq, annot) - | Prim (_, name, seq, annot) -> - Prim (id, name, List.map strip_locations seq, annot) in + | Seq (_, seq) -> + Seq (id, List.map strip_locations seq) + | Prim (_, name, seq, annots) -> + Prim (id, name, List.map strip_locations seq, annots) in Canonical (strip_locations root) let extract_locations root = @@ -71,12 +71,12 @@ let extract_locations root = | String (loc, v) -> loc_table := (id, loc) :: !loc_table ; String (id, v) - | Seq (loc, seq, annot) -> + | Seq (loc, seq) -> loc_table := (id, loc) :: !loc_table ; - Seq (id, List.map strip_locations seq, annot) - | Prim (loc, name, seq, annot) -> + Seq (id, List.map strip_locations seq) + | Prim (loc, name, seq, annots) -> loc_table := (id, loc) :: !loc_table ; - Prim (id, name, List.map strip_locations seq, annot) in + Prim (id, name, List.map strip_locations seq, annots) in let stripped = strip_locations root in Canonical stripped, List.rev !loc_table @@ -87,19 +87,19 @@ let inject_locations lookup (Canonical root) = Int (lookup loc, v) | String (loc, v) -> String (lookup loc, v) - | Seq (loc, seq, annot) -> - Seq (lookup loc, List.map inject_locations seq, annot) - | Prim (loc, name, seq, annot) -> - Prim (lookup loc, name, List.map inject_locations seq, annot) in + | Seq (loc, seq) -> + Seq (lookup loc, List.map inject_locations seq) + | Prim (loc, name, seq, annots) -> + Prim (lookup loc, name, List.map inject_locations seq, annots) in inject_locations root let map f (Canonical expr) = let rec map_node f = function | Int _ | String _ as node -> node - | Seq (loc, seq, annot) -> - Seq (loc, List.map (map_node f) seq, annot) - | Prim (loc, name, seq, annot) -> - Prim (loc, f name, List.map (map_node f) seq, annot) in + | Seq (loc, seq) -> + Seq (loc, List.map (map_node f) seq) + | Prim (loc, name, seq, annots) -> + Prim (loc, f name, List.map (map_node f) seq, annots) in Canonical (map_node f expr) let rec map_node fl fp = function @@ -107,10 +107,10 @@ let rec map_node fl fp = function Int (fl loc, v) | String (loc, v) -> String (fl loc, v) - | Seq (loc, seq, annot) -> - Seq (fl loc, List.map (map_node fl fp) seq, annot) - | Prim (loc, name, seq, annot) -> - Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot) + | Seq (loc, seq) -> + Seq (fl loc, List.map (map_node fl fp) seq) + | Prim (loc, name, seq, annots) -> + Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots) let canonical_encoding ~variant prim_encoding = let open Data_encoding in @@ -131,18 +131,18 @@ let canonical_encoding ~variant prim_encoding = let seq_encoding tag expr_encoding = case tag (list expr_encoding) ~title:"Sequence" - (function Seq (_, v, _annot) -> Some v | _ -> None) - (fun args -> Seq (0, args, None)) in + (function Seq (_, v) -> Some v | _ -> None) + (fun args -> Seq (0, args)) in let byte_string = Bounded.string 255 in let application_encoding tag expr_encoding = case tag ~title:"Generic prim (any number of args with or without annot)" (obj3 (req "prim" prim_encoding) - (req "args" (list expr_encoding)) - (opt "annot" byte_string)) - (function Prim (_, prim, args, annot) -> Some (prim, args, annot) + (dft "args" (list expr_encoding) []) + (dft "annots" (list byte_string) [])) + (function Prim (_, prim, args, annots) -> Some (prim, args, annots) | _ -> None) - (fun (prim, args, annot) -> Prim (0, prim, args, annot)) in + (fun (prim, args, annots) -> Prim (0, prim, args, annots)) in let node_encoding = mu ("micheline." ^ variant ^ ".expression") (fun expr_encoding -> splitted ~json:(union ~tag_size:`Uint8 @@ -158,37 +158,37 @@ let canonical_encoding ~variant prim_encoding = case (Tag 3) ~title:"Prim (no args, annot)" (obj1 (req "prim" prim_encoding)) - (function Prim (_, v, [], None) -> Some v + (function Prim (_, v, [], []) -> Some v | _ -> None) - (fun v -> Prim (0, v, [], None)) ; - (* No args, with annot *) + (fun v -> Prim (0, v, [], [])) ; + (* No args, with annots *) case (Tag 4) ~title:"Prim (no args + annot)" (obj2 (req "prim" prim_encoding) - (req "annot" byte_string)) + (req "annots" (list byte_string))) (function - | Prim (_, v, [], Some annot) -> Some (v, annot) + | Prim (_, v, [], annots) -> Some (v, annots) | _ -> None) - (function (prim, annot) -> Prim (0, prim, [], Some annot)) ; + (function (prim, annots) -> Prim (0, prim, [], annots)) ; (* Single arg, no annot *) case (Tag 5) ~title:"Prim (1 arg, no annot)" (obj2 (req "prim" prim_encoding) (req "arg" expr_encoding)) (function - | Prim (_, v, [ arg ], None) -> Some (v, arg) + | Prim (_, v, [ arg ], []) -> Some (v, arg) | _ -> None) - (function (prim, arg) -> Prim (0, prim, [ arg ], None)) ; + (function (prim, arg) -> Prim (0, prim, [ arg ], [])) ; (* Single arg, with annot *) case (Tag 6) ~title:"Prim (1 arg + annot)" (obj3 (req "prim" prim_encoding) (req "arg" expr_encoding) - (req "annot" byte_string)) + (req "annots" (list byte_string))) (function - | Prim (_, prim, [ arg ], Some annot) -> Some (prim, arg, annot) + | Prim (_, prim, [ arg ], annots) -> Some (prim, arg, annots) | _ -> None) - (fun (prim, arg, annot) -> Prim (0, prim, [ arg ], Some annot)) ; + (fun (prim, arg, annots) -> Prim (0, prim, [ arg ], annots)) ; (* Two args, no annot *) case (Tag 7) ~title:"Prim (2 args, no annot)" @@ -196,20 +196,20 @@ let canonical_encoding ~variant prim_encoding = (req "arg1" expr_encoding) (req "arg2" expr_encoding)) (function - | Prim (_, prim, [ arg1 ; arg2 ], None) -> Some (prim, arg1, arg2) + | Prim (_, prim, [ arg1 ; arg2 ], []) -> Some (prim, arg1, arg2) | _ -> None) - (fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], None)) ; - (* Two args, with annot *) + (fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], [])) ; + (* Two args, with annots *) case (Tag 8) ~title:"Prim (2 args + annot)" (obj4 (req "prim" prim_encoding) (req "arg1" expr_encoding) (req "arg2" expr_encoding) - (req "annot" byte_string)) + (req "annots" (list byte_string))) (function - | Prim (_, prim, [ arg1 ; arg2 ], Some annot) -> Some (prim, arg1, arg2, annot) + | Prim (_, prim, [ arg1 ; arg2 ], annots) -> Some (prim, arg1, arg2, annots) | _ -> None) - (fun (prim, arg1, arg2, annot) -> Prim (0, prim, [ arg1 ; arg2 ], Some annot)) ; + (fun (prim, arg1, arg2, annots) -> Prim (0, prim, [ arg1 ; arg2 ], annots)) ; (* General case *) application_encoding (Tag 9) expr_encoding ])) in diff --git a/src/lib_micheline/micheline.mli b/src/lib_micheline/micheline.mli index 385f45093..0a97b96c9 100644 --- a/src/lib_micheline/micheline.mli +++ b/src/lib_micheline/micheline.mli @@ -13,8 +13,8 @@ type ('l, 'p) node = | Int of 'l * Z.t | String of 'l * string - | Prim of 'l * 'p * ('l, 'p) node list * string option - | Seq of 'l * ('l, 'p) node list * string option + | Prim of 'l * 'p * ('l, 'p) node list * string list + | Seq of 'l * ('l, 'p) node list (** Encoding for expressions, as their {!canonical} encoding. Locations are stored in a side table. @@ -33,8 +33,8 @@ val erased_encoding : variant:string -> (** Extract the location of the node. *) val location : ('l, 'p) node -> 'l -(** Extract the annotation of the node. *) -val annotation : ('l, 'p) node -> string option +(** Extract the annotations of the node. *) +val annotations : ('l, 'p) node -> string list (** Expression form using canonical integer numbering as locations. The root has number zero, and each node adds one in the diff --git a/src/lib_micheline/micheline_parser.ml b/src/lib_micheline/micheline_parser.ml index d32f00f8c..dab3d555b 100644 --- a/src/lib_micheline/micheline_parser.ml +++ b/src/lib_micheline/micheline_parser.ml @@ -152,7 +152,7 @@ let tokenize source = | `Uchar c, start -> begin match uchar_to_char c with | Some ('a'..'z' | 'A'..'Z') -> ident acc start (fun s _ -> Ident s) - | Some '@' -> + | Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') -> ident acc start (fun str stop -> if String.length str > max_annot_length @@ -366,7 +366,7 @@ let min_point : node list -> point = function | Int ({ start }, _) :: _ | String ({ start }, _) :: _ | Prim ({ start }, _, _, _) :: _ - | Seq ({ start }, _, _) :: _ -> start + | Seq ({ start }, _) :: _ -> start (* End of a sequence of consecutive primitives *) let rec max_point : node list -> point = function @@ -375,7 +375,7 @@ let rec max_point : node list -> point = function | Int ({ stop }, _) :: [] | String ({ stop }, _) :: [] | Prim ({ stop }, _, _, _) :: [] - | Seq ({ stop }, _, _) :: [] -> stop + | Seq ({ stop }, _) :: [] -> stop (* An item in the parser's state stack. Not every value of type [mode list] is a valid parsing context. @@ -388,9 +388,9 @@ let rec max_point : node list -> point = function type mode = | Toplevel of node list | Expression of node option - | Sequence of token * node list * string option - | Unwrapped of location * string * node list * string option - | Wrapped of token * string * node list * string option + | Sequence of token * node list + | Unwrapped of location * string * node list * string list + | Wrapped of token * string * node list * string list (* Enter a new parsing state. *) let push_mode mode stack = @@ -413,8 +413,8 @@ let fill_mode result = function Expression (Some result) :: [] | Toplevel exprs :: [] -> Toplevel (result :: exprs) :: [] - | Sequence (token, exprs, annot) :: rest -> - Sequence (token, result :: exprs, annot) :: rest + | Sequence (token, exprs) :: rest -> + Sequence (token, result :: exprs) :: rest | Wrapped (token, name, exprs, annot) :: rest -> Wrapped (token, name, result :: exprs, annot) :: rest | Unwrapped (start, name, exprs, annot) :: rest -> @@ -426,6 +426,12 @@ type error += Extra of token type error += Misaligned of node type error += Empty +let rec annots = function + | { token = Annot annot } :: rest -> + let annots, rest = annots rest in + annot :: annots, rest + | rest -> [], rest + let rec parse ?(check = true) errors tokens stack = (* Two steps: - 1. parse without checking indentation [parse] @@ -451,8 +457,8 @@ let rec parse ?(check = true) errors tokens stack = | Expression None :: _, [] -> let errors = Empty :: errors in let ghost = { start = point_zero ; stop = point_zero} in - [ Seq (ghost, [], None) ], List.rev errors - | Toplevel [ Seq (_, exprs, _) as expr ] :: [], + [ Seq (ghost, []) ], List.rev errors + | Toplevel [ Seq (_, exprs) as expr ] :: [], [] -> let errors = if check then do_check ~toplevel: false errors expr else errors in exprs, List.rev errors @@ -460,7 +466,7 @@ let rec parse ?(check = true) errors tokens stack = [] -> let exprs = List.rev exprs in let loc = { start = min_point exprs ; stop = max_point exprs } in - let expr = Seq (loc, exprs, None) in + let expr = Seq (loc, exprs) in let errors = if check then do_check ~toplevel: true errors expr else errors in exprs, List.rev errors (* Ignore comments *) @@ -517,19 +523,20 @@ let rec parse ?(check = true) errors tokens stack = let fake = { token with token = Close_paren } in let tokens = (* insert *) fake :: tokens in parse ~check errors tokens stack - | (Sequence (token, _, _) :: _ | Unwrapped _ :: Sequence (token, _, _) :: _), [] -> + | (Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [] -> let errors = Unclosed token :: errors in let fake = { token with token = Close_brace } in let tokens = (* insert *) fake :: tokens in parse ~check errors tokens stack (* Valid states *) - | (Toplevel _ | Sequence (_, _, _)) :: _ , - { token = Ident name ; loc } :: { token = Annot annot } :: rest -> - let mode = Unwrapped (loc, name, [], Some annot) in + | (Toplevel _ | Sequence (_, _)) :: _ , + { token = Ident name ; loc } :: ({ token = Annot _ } :: _ as rest) -> + let annots, rest = annots rest in + let mode = Unwrapped (loc, name, [], annots) in parse ~check errors rest (push_mode mode stack) - | (Expression None | Toplevel _ | Sequence (_, _, _)) :: _ , + | (Expression None | Toplevel _ | Sequence (_, _)) :: _ , { token = Ident name ; loc } :: rest -> - let mode = Unwrapped (loc, name, [], None) in + let mode = Unwrapped (loc, name, [], []) in parse ~check errors rest (push_mode mode stack) | (Unwrapped _ | Wrapped _) :: _, { token = Int value ; loc } :: rest @@ -545,10 +552,10 @@ let rec parse ?(check = true) errors tokens stack = let expr : node = String (loc, contents) in let errors = if check then do_check ~toplevel: false errors expr else errors in parse ~check errors rest (fill_mode expr stack) - | Sequence ({ loc = { start } }, exprs, annot) :: _ , + | Sequence ({ loc = { start } }, exprs) :: _ , { token = Close_brace ; loc = { stop } } :: rest -> let exprs = List.rev exprs in - let expr = Micheline.Seq ({ start ; stop }, exprs, annot) in + let expr = Micheline.Seq ({ start ; stop }, exprs) in let errors = if check then do_check ~toplevel: false errors expr else errors in parse ~check errors rest (fill_mode expr (pop_mode stack)) | (Sequence _ | Toplevel _) :: _ , @@ -568,34 +575,31 @@ let rec parse ?(check = true) errors tokens stack = let errors = if check then do_check ~toplevel: false errors expr else errors in parse ~check errors rest (fill_mode expr (pop_mode stack)) | (Wrapped _ | Unwrapped _) :: _ , - ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> - let mode = Wrapped (token, name, [], Some annot) in + ({ token = Open_paren } as token) :: { token = Ident name } :: ({ token = Annot _ } :: _ as rest) -> + let annots, rest = annots rest in + let mode = Wrapped (token, name, [], annots) in parse ~check errors rest (push_mode mode stack) | (Wrapped _ | Unwrapped _) :: _ , ({ token = Open_paren } as token) :: { token = Ident name } :: rest -> - let mode = Wrapped (token, name, [], None) in + let mode = Wrapped (token, name, [], []) in parse ~check errors rest (push_mode mode stack) | (Wrapped _ | Unwrapped _) :: _ , { token = Ident name ; loc } :: rest -> - let expr = Micheline.Prim (loc, name, [], None) in + let expr = Micheline.Prim (loc, name, [], []) in let errors = if check then do_check ~toplevel: false errors expr else errors in parse ~check errors rest (fill_mode expr stack) - | (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _ , - ({ token = Open_brace } as token) :: { token = Annot annot } :: rest -> - let mode = Sequence (token, [], Some annot) in - parse ~check errors rest (push_mode mode stack) | (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _ , ({ token = Open_brace } as token) :: rest -> - let mode = Sequence (token, [], None) in + let mode = Sequence (token, []) in parse ~check errors rest (push_mode mode stack) (* indentation checker *) and do_check ?(toplevel = false) errors = function - | Seq ({ start ; stop }, [], _) as expr -> + | Seq ({ start ; stop }, []) as expr -> if start.column >= stop.column then Misaligned expr :: errors else errors | Prim ({ start ; stop }, _, first :: rest, _) - | Seq ({ start ; stop }, first :: rest, _) as expr -> + | Seq ({ start ; stop }, first :: rest) as expr -> let { column = first_column ; line = first_line } = min_point [ first ] in if start.column >= stop.column then @@ -623,11 +627,12 @@ and do_check ?(toplevel = false) errors = function let parse_expression ?check tokens = let result = match tokens with - | ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot annot } :: rest -> - let mode = Wrapped (token, name, [], Some annot) in + | ({ token = Open_paren } as token) :: { token = Ident name } :: { token = Annot _ } :: rest -> + let annots, rest = annots rest in + let mode = Wrapped (token, name, [], annots) in parse ?check [] rest [ mode ; Expression None ] | ({ token = Open_paren } as token) :: { token = Ident name } :: rest -> - let mode = Wrapped (token, name, [], None) in + let mode = Wrapped (token, name, [], []) in parse ?check [] rest [ mode ; Expression None ] | _ -> parse ?check [] tokens [ Expression None ] in diff --git a/src/lib_micheline/micheline_printer.ml b/src/lib_micheline/micheline_printer.ml index 370b6b68e..bfa86bfac 100644 --- a/src/lib_micheline/micheline_printer.ml +++ b/src/lib_micheline/micheline_printer.ml @@ -42,9 +42,9 @@ let preformat root = (false, 0) | { comment = Some text } -> (String.contains text '\n', String.length text + 1) in - let preformat_annot = function - | None -> 0 - | Some annot -> String.length annot + 2 in + let preformat_annots = function + | [] -> 0 + | annots -> String.length (String.concat " " annots) + 2 in let rec preformat_expr = function | Int (loc, value) -> let cml, csz = preformat_loc loc in @@ -52,9 +52,9 @@ let preformat root = | String (loc, value) -> let cml, csz = preformat_loc loc in String ((cml, String.length value + csz, loc), value) - | Prim (loc, name, items, annot) -> + | Prim (loc, name, items, annots) -> let cml, csz = preformat_loc loc in - let asz = preformat_annot annot in + let asz = preformat_annots annots in let items = List.map preformat_expr items in let ml, sz = List.fold_left @@ -63,26 +63,25 @@ let preformat root = (tml || ml, tsz + 1 + sz)) (cml, String.length name + csz + asz) items in - Prim ((ml, sz, loc), name, items, annot) - | Seq (loc, items, annot) -> + Prim ((ml, sz, loc), name, items, annots) + | Seq (loc, items) -> let cml, csz = preformat_loc loc in - let asz = preformat_annot annot in let items = List.map preformat_expr items in let ml, sz = List.fold_left (fun (tml, tsz) e -> let (ml, sz, _) = location e in (tml || ml, tsz + 3 + sz)) - (cml, 4 + csz + asz) + (cml, 4 + csz) items in - Seq ((ml, sz, loc), items, annot) in + Seq ((ml, sz, loc), items) in preformat_expr root let rec print_expr_unwrapped ppf = function | Prim ((ml, s, { comment }), name, args, annot) -> let name = match annot with - | None -> name - | Some annot -> Format.asprintf "%s %s" name annot in + | [] -> name + | annots -> Format.asprintf "%s @[%a@]" name (Format.pp_print_list Format.pp_print_string) annots in if not ml && s < 80 then begin if args = [] then Format.fprintf ppf "%s" name @@ -114,18 +113,13 @@ let rec print_expr_unwrapped ppf = function | None -> print_string ppf value | Some comment -> Format.fprintf ppf "%a@ %a" print_string value print_comment comment end - | Seq ((_, _, { comment = None }), [], None) -> + | Seq ((_, _, { comment = None }), []) -> Format.fprintf ppf "{}" - | Seq ((ml, s, { comment }), items, annot) -> + | Seq ((ml, s, { comment }), items) -> if not ml && s < 80 then Format.fprintf ppf "{ @[" else Format.fprintf ppf "{ @[" ; - begin match annot, comment, items with - | None, _, _ -> () - | Some annot, None, [] -> Format.fprintf ppf "%s" annot - | Some annot, _, _ -> Format.fprintf ppf "%s@ " annot - end ; begin match comment, items with | None, _ -> () | Some comment, [] -> Format.fprintf ppf "%a" print_comment comment @@ -139,7 +133,7 @@ let rec print_expr_unwrapped ppf = function and print_expr ppf = function | Prim (_, _, _ :: _, _) - | Prim (_, _, [], Some _) as expr -> + | Prim (_, _, [], _ :: _) as expr -> Format.fprintf ppf "(%a)" print_expr_unwrapped expr | expr -> print_expr_unwrapped ppf expr diff --git a/src/lib_protocol_environment/sigs/v1/micheline.mli b/src/lib_protocol_environment/sigs/v1/micheline.mli index e5d789cda..f1f1573d9 100644 --- a/src/lib_protocol_environment/sigs/v1/micheline.mli +++ b/src/lib_protocol_environment/sigs/v1/micheline.mli @@ -10,8 +10,8 @@ type ('l, 'p) node = | Int of 'l * Z.t | String of 'l * string - | Prim of 'l * 'p * ('l, 'p) node list * string option - | Seq of 'l * ('l, 'p) node list * string option + | Prim of 'l * 'p * ('l, 'p) node list * string list + | Seq of 'l * ('l, 'p) node list type 'p canonical type canonical_location = int @@ -23,7 +23,7 @@ val erased_encoding : variant:string -> 'l -> 'p Data_encoding.encoding -> ('l, val table_encoding : variant:string -> 'l Data_encoding.encoding -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding val location : ('l, 'p) node -> 'l -val annotation : ('l, 'p) node -> string option +val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list diff --git a/src/proto_alpha/lib_baking/test/test_michelson_parser.ml b/src/proto_alpha/lib_baking/test/test_michelson_parser.ml index 78c8960a1..712743975 100644 --- a/src/proto_alpha/lib_baking/test/test_michelson_parser.ml +++ b/src/proto_alpha/lib_baking/test/test_michelson_parser.ml @@ -115,80 +115,72 @@ let assert_expands original expanded = ok () | errors -> Error errors -let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], None) ], None) -let right_branch = Seq(zero_loc, [ ], None) +let left_branch = Seq(zero_loc, [ Prim(zero_loc, "SWAP", [], []) ]) +let right_branch = Seq(zero_loc, []) let test_expansion () = - assert_expands (Prim (zero_loc, "CAAR", [], None)) + assert_expands (Prim (zero_loc, "CAAR", [], [])) (Seq (zero_loc, - [(Prim (zero_loc, "CAR", [], None)); - (Prim (zero_loc, "CAR", [], None)) ], - None)) >>? fun () -> - assert_expands (Prim (zero_loc, "CAAR", [], Some "annot")) + [(Prim (zero_loc, "CAR", [], [])); + (Prim (zero_loc, "CAR", [], [])) ])) >>? fun () -> + assert_expands (Prim (zero_loc, "CAAR", [], [ "annot" ])) (Seq (zero_loc, - [(Prim (zero_loc, "CAR", [], None)); - (Prim (zero_loc, "CAR", [], Some "annot")) ], - None)) >>? fun () -> - let car = Prim (zero_loc, "CAR", [], Some "annot") in + [(Prim (zero_loc, "CAR", [], [])); + (Prim (zero_loc, "CAR", [], [ "annot" ])) ])) >>? fun () -> + let car = Prim (zero_loc, "CAR", [], [ "annot" ]) in assert_expands car car >>? fun () -> - let arg = [ Seq (zero_loc, [ car ], None) ] in + let arg = [ Seq (zero_loc, [ car ]) ] in assert_expands - (Prim (zero_loc, "DIP", arg, Some "new_annot")) - (Prim (zero_loc, "DIP", arg, Some "new_annot")) >>? fun () -> + (Prim (zero_loc, "DIP", arg, [ "new_annot" ])) + (Prim (zero_loc, "DIP", arg, [ "new_annot" ])) >>? fun () -> assert_expands - (Prim (zero_loc, "DIIP", arg, None)) + (Prim (zero_loc, "DIIP", arg, [])) (Seq (zero_loc, [ Prim (zero_loc, "DIP", [ (Seq (zero_loc, - [ Prim (zero_loc, "DIP", arg, None) ], - None)) ], - None) ], - None)) >>? fun () -> + [ Prim (zero_loc, "DIP", arg, []) ])) ], + []) ])) >>? fun () -> assert_expands - (Prim (zero_loc, "DIIIP", arg, None)) + (Prim (zero_loc, "DIIIP", arg, [])) (Seq (zero_loc, [ Prim (zero_loc, "DIP", [ (Seq (zero_loc, [ Prim (zero_loc, "DIP", [ (Seq (zero_loc, - [ Prim (zero_loc, "DIP", arg, None) ], - None)) ], - None) ], - None)) ], - None) ], - None)) >>? fun () -> + [ Prim (zero_loc, "DIP", arg, []) ])) ], + []) ])) ], + []) ])) >>? fun () -> assert_expands - (Prim (zero_loc, "DUUP", [], None)) + (Prim (zero_loc, "DUUP", [], [])) (Seq (zero_loc, - [ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None) ], None) ; - Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () -> + [ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ]) ], []) ; + Prim (zero_loc, "SWAP", [], []) ])) >>? fun () -> assert_expands - (Prim (zero_loc, "DUUUP", [], None)) + (Prim (zero_loc, "DUUUP", [], [])) (Seq (zero_loc, [ Prim (zero_loc, "DIP", [ Seq (zero_loc, [ Prim (zero_loc, "DIP", [ - Seq (zero_loc, [ Prim (zero_loc, "DUP", [], None) ], None)], - None); - Prim (zero_loc, "SWAP", [], None) ], - None) ], - None) ; - Prim (zero_loc, "SWAP", [], None) ], None)) >>? fun () -> + Seq (zero_loc, [ Prim (zero_loc, "DUP", [], []) ])], + []); + Prim (zero_loc, "SWAP", [], []) ]) ], + []) ; + Prim (zero_loc, "SWAP", [], []) ])) >>? fun () -> let assert_compare_macro prim_name compare_name = assert_expands - (Prim (zero_loc, prim_name, [], None)) + (Prim (zero_loc, prim_name, [], [])) (Seq (zero_loc, - [ Prim (zero_loc, "COMPARE", [], None) ; - Prim (zero_loc, compare_name, [], None) ], None)) in + [ Prim (zero_loc, "COMPARE", [], []) ; + Prim (zero_loc, compare_name, [], []) ])) in let assert_compare_if_macro prim_name compare_name = assert_expands (Prim (zero_loc, prim_name, [ left_branch ; right_branch ], - None)) - (Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], None); - Prim(zero_loc, compare_name, [], None); - Prim (zero_loc, "IF", [ left_branch ; right_branch ], None) ], None)) in + [])) + (Seq (zero_loc, [ Prim(zero_loc, "COMPARE", [], []); + Prim(zero_loc, compare_name, [], []); + Prim (zero_loc, "IF", [ left_branch ; right_branch ], []) ])) in assert_compare_macro "CMPEQ" "EQ" >>? fun () -> assert_compare_macro "CMPNEQ" "NEQ" >>? fun () -> assert_compare_macro "CMPLT" "LT" >>? fun () -> @@ -201,50 +193,41 @@ let test_expansion () = assert_compare_if_macro "IFCMPLE" "LE" >>? fun () -> assert_compare_if_macro "IFCMPGT" "GT" >>? fun () -> assert_compare_if_macro "IFCMPGE" "GE" >>? fun () -> - assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], None)) + assert_expands (Prim (zero_loc, "ASSERT_LEFT", [], [])) (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", - [ Seq (zero_loc, [ ], None) ; - Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ], - None) ], None)) >>? fun () -> - assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], None)) + [ Seq (zero_loc, []) ; + Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ], + []) ])) >>? fun () -> + assert_expands (Prim (zero_loc, "ASSERT_RIGHT", [], [])) (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", - [ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], None) ], None) ; - Seq (zero_loc, [ ], None) ], - None) ], None)) >>? fun () -> - assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], None)) - (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], None) ], None)) >>? fun () -> - assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], None)) - (Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], None) ], None)) >>? fun () -> + [ Seq (zero_loc, [ Prim(zero_loc, "FAIL", [], []) ]) ; + Seq (zero_loc, []) ], + []) ])) >>? fun () -> + assert_expands (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch ], [])) + (Seq (zero_loc, [ Prim (zero_loc, "IF_LEFT", [ right_branch ; left_branch ], []) ])) >>? fun () -> + assert_expands (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch ], [])) + (Seq (zero_loc, [ Prim (zero_loc, "IF_NONE", [ right_branch ; left_branch ], []) ])) >>? fun () -> assert_expands - (Prim (zero_loc, "PAIR", [], None)) - (Prim (zero_loc, "PAIR", [], None)) >>? fun () -> + (Prim (zero_loc, "PAIR", [], [])) + (Prim (zero_loc, "PAIR", [], [])) >>? fun () -> assert_expands - (Prim (zero_loc, "PAAIR", [], None)) + (Prim (zero_loc, "PAAIR", [], [])) (Seq (zero_loc, [Prim (zero_loc, "DIP", - [Seq (zero_loc, [Prim - (zero_loc, "PAIR", [], None)], - None)], - None)], - None)) >>? fun () -> + [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])], + [])])) >>? fun () -> assert_expands - (Prim (zero_loc, "PAAIAIR", [], None)) + (Prim (zero_loc, "PAAIAIR", [], [])) (Seq (zero_loc, [Prim (zero_loc, "DIP", [Seq (zero_loc, - [Prim - (zero_loc, - "PAIR", [], None)], - None)], - None); - Prim - (zero_loc, - "PAIR", [], None)], - None)) + [Prim (zero_loc, "PAIR", [], [])])], + []); + Prim (zero_loc, "PAIR", [], [])])) let assert_unexpansion_consistent original = let { Michelson_v1_parser.expanded }, errors = @@ -259,30 +242,30 @@ let assert_unexpansion_consistent original = ok () let test_unexpansion_consistency () = - assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], None)) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "PAAAIAIR", [], [])) >>? fun () -> assert_unexpansion_consistent - (Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], None) ], None) ], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "DUUUUUP", [], None)) >>? fun () -> + (Prim (zero_loc, "DIIIP", [ Seq (zero_loc, [ Prim (zero_loc, "DROP", [], []) ]) ], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "SET_CAR", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "SET_CDR", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "DUP", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "DUUP", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "DUUUP", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "DUUUUP", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "DUUUUUP", [], [])) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_EQ", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_RIGHT", [], None)) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_EQ", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NEQ", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LT", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LE", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GT", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_GE", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_NONE", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_SOME", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_LEFT", [], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "ASSERT_RIGHT", [], [])) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch], None)) >>? fun () -> - assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], None)) + assert_unexpansion_consistent (Prim (zero_loc, "IF_RIGHT", [ left_branch ; right_branch], [])) >>? fun () -> + assert_unexpansion_consistent (Prim (zero_loc, "IF_SOME", [ left_branch ; right_branch], [])) let test_lexing () = let open Micheline_parser in @@ -329,96 +312,96 @@ let test_parsing () = ok () in assert_parses "PUSH int 100" - [ (Prim ((), "PUSH", [ Prim ((), "int", [], None) ; - Int ((), Z.of_int 100) ], None)) ] >>? fun () -> + [ (Prim ((), "PUSH", [ Prim ((), "int", [], []) ; + Int ((), Z.of_int 100) ], [])) ] >>? fun () -> - assert_parses "DROP" [ (Prim ((), "DROP", [], None)) ] >>? fun () -> + assert_parses "DROP" [ (Prim ((), "DROP", [], [])) ] >>? fun () -> assert_parses "DIP{DROP}" - [ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], None) ], None) ], None) ] >>? fun () -> + [ Prim ((), "DIP", [ Seq((), [ Prim ((), "DROP", [], []) ]) ], []) ] >>? fun () -> assert_parses "LAMBDA int int {}" - [ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ; - Prim ((), "int", [], None) ; - Seq ((), [ ], None) ], None) ] >>? fun () -> + [ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ; + Prim ((), "int", [], []) ; + Seq ((), []) ], []) ] >>? fun () -> assert_parses "LAMBDA @name int int {}" - [ Prim ((), "LAMBDA", [ Prim ((), "int", [], None) ; - Prim ((), "int", [], None) ; - Seq ((), [ ], None) ], Some "@name") ] >>? fun () -> + [ Prim ((), "LAMBDA", [ Prim ((), "int", [], []) ; + Prim ((), "int", [], []) ; + Seq ((), []) ], [ "@name" ]) ] >>? fun () -> assert_parses "NIL @annot string; # comment\n" - [ Prim ((), "NIL", [ Prim ((), "string", [], None) ], Some "@annot") ] >>? fun () -> + [ Prim ((), "NIL", [ Prim ((), "string", [], []) ], [ "@annot" ]) ] >>? fun () -> assert_parses "PUSH (pair bool string) (Pair False \"abc\")" [ Prim ((), "PUSH", [ Prim ((), "pair", - [ Prim ((), "bool", [], None) ; - Prim ((), "string", [], None) ], None) ; + [ Prim ((), "bool", [], []) ; + Prim ((), "string", [], []) ], []) ; Prim ((), "Pair", - [ Prim ((), "False", [], None) ; - String ((), "abc")], None) ], None) ] >>? fun () -> + [ Prim ((), "False", [], []) ; + String ((), "abc")], []) ], []) ] >>? fun () -> assert_parses "PUSH (list nat) (List 1 2 3)" [ Prim ((), "PUSH", [ Prim ((), "list", - [ Prim ((), "nat", [], None) ], None) ; + [ Prim ((), "nat", [], []) ], []) ; Prim ((), "List", [ Int((), Z.of_int 1); Int ((), Z.of_int 2); Int ((), Z.of_int 3)], - None) ], None) ] >>? fun () -> + []) ], []) ] >>? fun () -> assert_parses "PUSH (lambda nat nat) {}" [ Prim ((), "PUSH", [ Prim ((), "lambda", - [ Prim ((), "nat", [], None); - Prim ((), "nat", [], None)], None) ; - Seq((), [], None)], - None) ] >>? fun () -> + [ Prim ((), "nat", [], []); + Prim ((), "nat", [], [])], []) ; + Seq((), [])], + []) ] >>? fun () -> assert_parses "PUSH key \"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx\"" - [ Prim ((), "PUSH", [ Prim ((), "key", [], None) ; + [ Prim ((), "PUSH", [ Prim ((), "key", [], []) ; String ((),"tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx") ], - None) ] >>? fun () -> + []) ] >>? fun () -> assert_parses "PUSH (map int bool) (Map (Item 100 False))" [ Prim ((), "PUSH", [ Prim ((), "map", - [ Prim((), "int", [], None); - Prim((), "bool", [], None)], None) ; + [ Prim((), "int", [], []); + Prim((), "bool", [], [])], []) ; Prim ((), "Map", [Prim ((), "Item", [Int ((), Z.of_int 100); - Prim ((), "False", [], None)], None)], None) ], - None) ] >>? fun () -> + Prim ((), "False", [], [])], [])], []) ], + []) ] >>? fun () -> assert_parses "parameter int; \ return int; \ storage unit; \ code {}" - [ Prim ((), "parameter", [ Prim((), "int", [], None) ], None); - Prim ((), "return", [ Prim((), "int", [], None) ], None); - Prim ((), "storage", [ Prim((), "unit", [], None) ], None); - Prim ((), "code", [ Seq((), [], None) ], None)] >>? fun () -> + [ Prim ((), "parameter", [ Prim((), "int", [], []) ], []); + Prim ((), "return", [ Prim((), "int", [], []) ], []); + Prim ((), "storage", [ Prim((), "unit", [], []) ], []); + Prim ((), "code", [ Seq((), []) ], [])] >>? fun () -> assert_parses "parameter int; \ storage unit; \ return int; \ code {CAR; PUSH int 1; ADD; UNIT; SWAP; PAIR};" - [ Prim ((), "parameter", [ Prim((), "int", [], None) ], None); - Prim ((), "storage", [ Prim((), "unit", [], None) ], None); - Prim ((), "return", [ Prim((), "int", [], None) ], None); - Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], None) ; - Prim ((), "PUSH", [ Prim((), "int", [], None) ; - Int ((), Z.of_int 1)], None) ; - Prim ((), "ADD", [], None) ; - Prim ((), "UNIT", [], None) ; - Prim ((), "SWAP", [], None) ; - Prim ((), "PAIR", [], None)], None) ], None)] >>? fun () -> + [ Prim ((), "parameter", [ Prim((), "int", [], []) ], []); + Prim ((), "storage", [ Prim((), "unit", [], []) ], []); + Prim ((), "return", [ Prim((), "int", [], []) ], []); + Prim ((), "code", [ Seq((), [ Prim ((), "CAR", [], []) ; + Prim ((), "PUSH", [ Prim((), "int", [], []) ; + Int ((), Z.of_int 1)], []) ; + Prim ((), "ADD", [], []) ; + Prim ((), "UNIT", [], []) ; + Prim ((), "SWAP", [], []) ; + Prim ((), "PAIR", [], [])]) ], [])] >>? fun () -> assert_parses "code {DUP @test; DROP}" - [ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], Some "@test"); - Prim ((), "DROP", [], None)], None)], None) ] >>? fun () -> + [ Prim ((), "code", [Seq ((), [ Prim ((), "DUP", [], [ "@test" ]); + Prim ((), "DROP", [], [])])], []) ] >>? fun () -> assert_parses "IF {CAR} {CDR}" - [ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], None) ], None); - Seq ((), [ Prim ((), "CDR", [], None) ], None) ], None) ] >>? fun () -> + [ Prim ((), "IF", [ Seq ((), [ Prim ((), "CAR", [], []) ]); + Seq ((), [ Prim ((), "CDR", [], []) ]) ], []) ] >>? fun () -> assert_parses "IF_NONE {FAIL} {}" - [ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], None) ], None); - Seq ((), [ ], None) ], None) ] + [ Prim ((), "IF_NONE", [ Seq ((), [ Prim ((), "FAIL", [], []) ]); + Seq ((), []) ], []) ] let tests = [ "lexing", (fun _ -> Lwt.return (test_lexing ())) ; diff --git a/src/proto_alpha/lib_client/michelson_v1_emacs.ml b/src/proto_alpha/lib_client/michelson_v1_emacs.ml index 084227b0a..0e37fbfd1 100644 --- a/src/proto_alpha/lib_client/michelson_v1_emacs.ml +++ b/src/proto_alpha/lib_client/michelson_v1_emacs.ml @@ -13,17 +13,16 @@ open Micheline let print_expr ppf expr = let print_annot ppf = function - | None -> () - | Some annot -> Format.fprintf ppf " %s" annot in + | [] -> () + | annots -> Format.fprintf ppf " %s" (String.concat " " annots) in let rec print_expr ppf = function | Int (_, value) -> Format.fprintf ppf "%s" (Z.to_string value) | String (_, value) -> Micheline_printer.print_string ppf value - | Seq (_, items, annot) -> - Format.fprintf ppf "(seq%a %a)" - print_annot annot + | Seq (_, items) -> + Format.fprintf ppf "(seq %a)" (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr) items - | Prim (_, name, [], None) -> + | Prim (_, name, [], []) -> Format.fprintf ppf "%s" name | Prim (_, name, items, annot) -> Format.fprintf ppf "(%s%a%s%a)" @@ -39,12 +38,12 @@ open Script_tc_errors let print_type_map ppf (parsed, type_map) = let rec print_expr_types ppf = function - | Seq (loc, [], _) + | Seq (loc, []) | Prim (loc, _, [], _) | Int (loc, _) | String (loc, _) -> print_item ppf loc - | Seq (loc, items, _) + | Seq (loc, items) | Prim (loc, _, items, _) -> print_item ppf loc ; List.iter (print_expr_types ppf) items 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 fbfd6f1f8..a0e23e6e2 100644 --- a/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml +++ b/src/proto_alpha/lib_client/michelson_v1_error_reporter.ml @@ -148,7 +148,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = | Some s -> Format.fprintf ppf "%s " s) name print_source (parsed, hilights) - print_ty (None, ty) ; + print_ty ([], ty) ; if rest <> [] then Format.fprintf ppf "@," ; print_trace (parsed_locations parsed) rest | Alpha_environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest -> @@ -325,21 +325,21 @@ let report_errors ~details ~show_source ?parsed ppf errs = @[and@ %a.@]@]" print_loc loc (Michelson_v1_primitives.string_of_prim name) - print_ty (None, tya) - print_ty (None, tyb) + print_ty ([], tya) + print_ty ([], tyb) | Undefined_unop (loc, name, ty) -> Format.fprintf ppf "@[@[%aoperator %s is undefined on@ %a@]@]" print_loc loc (Michelson_v1_primitives.string_of_prim name) - print_ty (None, ty) + print_ty ([], ty) | Bad_return (loc, got, exp) -> Format.fprintf ppf "@[%awrong stack type at end of body:@,\ - @[expected return stack type:@ %a,@]@,\ - @[actual stack type:@ %a.@]@]" print_loc loc - (fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, None)) + (fun ppf -> print_stack_ty ppf) (Item_t (exp, Empty_t, [])) (fun ppf -> print_stack_ty ppf) got | Bad_stack (loc, name, depth, sty) -> Format.fprintf ppf @@ -358,17 +358,18 @@ let report_errors ~details ~show_source ?parsed ppf errs = | Inconsistent_annotations (annot1, annot2) -> Format.fprintf ppf "@[The two annotations do not match:@,\ - - @[%s@]@,\ - - @[%s@]" - annot1 annot2 + - @[%a@]@,\ + - @[%a@]@]" + (Format.pp_print_list Format.pp_print_string) annot1 + (Format.pp_print_list Format.pp_print_string) annot2 | Inconsistent_type_annotations (loc, ty1, ty2) -> Format.fprintf ppf "@[%athe two types contain incompatible annotations:@,\ - @[%a@]@,\ - - @[%a@]" + - @[%a@]@]" print_loc loc - print_ty (None, ty1) - print_ty (None, ty2) + print_ty ([], ty1) + print_ty ([], ty2) | Unexpected_annotation loc -> Format.fprintf ppf "@[%aunexpected annotation." @@ -395,7 +396,7 @@ let report_errors ~details ~show_source ?parsed ppf errs = @[is invalid for type@ %a.@]@]" print_loc loc print_expr got - print_ty (None, exp) + print_ty ([], exp) | Invalid_contract (loc, contract) -> Format.fprintf ppf "%ainvalid contract %a." @@ -404,13 +405,13 @@ let report_errors ~details ~show_source ?parsed ppf errs = Format.fprintf ppf "%acomparable type expected." print_loc loc ; Format.fprintf ppf "@[@[Type@ %a@]@ is not comparable.@]" - print_ty (None, ty) + print_ty ([], ty) | Inconsistent_types (tya, tyb) -> Format.fprintf ppf "@[@[Type@ %a@]@ \ @[is not compatible with type@ %a.@]@]" - print_ty (None, tya) - print_ty (None, tyb) + print_ty ([], tya) + print_ty ([], tyb) | Reject loc -> Format.fprintf ppf "%ascript reached FAIL instruction" print_loc loc diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index a3f2d6663..8aea5c349 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/src/proto_alpha/lib_client/michelson_v1_macros.ml @@ -32,16 +32,16 @@ let expand_caddadr original = | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) end >>? fun () -> - let rec parse i ?annot acc = + let rec parse i annot acc = if i = 0 then - Seq (loc, acc, None) + Seq (loc, acc) else - let annot = if i = (String.length str - 2) then annot else None in + let annot = if i = (String.length str - 2) then annot else [] 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) + | 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc) + | 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc) | _ -> assert false in - ok (Some (parse (len - 2) ?annot [])) + ok (Some (parse (len - 2) annot [])) else ok None | _ -> ok None @@ -67,45 +67,45 @@ let expand_set_caddadr original = | 'A' -> let acc = Seq (loc, - [ Prim (loc, "DUP", [], None) ; + [ Prim (loc, "DUP", [], []) ; Prim (loc, "DIP", [ Seq (loc, - [ Prim (loc, "CAR", [], None) ; - acc ], None) ], None) ; - Prim (loc, "CDR", [], None) ; - Prim (loc, "SWAP", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + [ Prim (loc, "CAR", [], []) ; + acc ]) ], []) ; + Prim (loc, "CDR", [], []) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], []) ]) in parse (i - 1) acc | 'D' -> let acc = Seq (loc, - [ Prim (loc, "DUP", [], None) ; + [ Prim (loc, "DUP", [], []) ; Prim (loc, "DIP", [ Seq (loc, - [ Prim (loc, "CDR", [], None) ; - acc ], None) ], None) ; - Prim (loc, "CAR", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + [ Prim (loc, "CDR", [], []) ; + acc ]) ], []) ; + Prim (loc, "CAR", [], []) ; + Prim (loc, "PAIR", [], []) ]) in parse (i - 1) acc | _ -> assert false in match String.get str (len - 2) with | 'A' -> let init = Seq (loc, - [ Prim (loc, "CDR", [], None) ; + [ Prim (loc, "CDR", [], []) ; Prim (loc, "SWAP", [], annot) ; - Prim (loc, "PAIR", [], None) ], None) in + Prim (loc, "PAIR", [], []) ]) in ok (Some (parse (len - 3) init)) | 'D' -> let init = Seq (loc, - (Prim (loc, "CAR", [], None)) :: - (let pair = Prim (loc, "PAIR", [], None) in + (Prim (loc, "CAR", [], [])) :: + (let pair = Prim (loc, "PAIR", [], []) in match annot with - | None -> [ pair ] - | Some _ -> [ Prim (loc, "SWAP", [], annot) ; - Prim (loc, "SWAP", [], None) ; - pair]), None) in + | [] -> [ pair ] + | _ -> [ Prim (loc, "SWAP", [], annot) ; + Prim (loc, "SWAP", [], []) ; + pair])) in ok (Some (parse (len - 3) init)) | _ -> assert false else @@ -122,8 +122,8 @@ let expand_map_caddadr original = && check_letters str 5 (len - 2) (function 'A' | 'D' -> true | _ -> false) then begin match annot with - | Some _ -> (error (Unexpected_macro_annotation str)) - | None -> ok () + | _ :: _ -> (error (Unexpected_macro_annotation str)) + | [] -> ok () end >>? fun () -> begin match args with | [ Seq _ as code ] -> ok code @@ -138,47 +138,47 @@ let expand_map_caddadr original = | 'A' -> let acc = Seq (loc, - [ Prim (loc, "DUP", [], None) ; + [ Prim (loc, "DUP", [], []) ; Prim (loc, "DIP", [ Seq (loc, - [ Prim (loc, "CAR", [], None) ; - acc ], None) ], None) ; - Prim (loc, "CDR", [], None) ; - Prim (loc, "SWAP", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + [ Prim (loc, "CAR", [], []) ; + acc ]) ], []) ; + Prim (loc, "CDR", [], []) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], []) ]) in parse (i - 1) acc | 'D' -> let acc = Seq (loc, - [ Prim (loc, "DUP", [], None) ; + [ Prim (loc, "DUP", [], []) ; Prim (loc, "DIP", [ Seq (loc, - [ Prim (loc, "CDR", [], None) ; - acc ], None) ], None) ; - Prim (loc, "CAR", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + [ Prim (loc, "CDR", [], []) ; + acc ]) ], []) ; + Prim (loc, "CAR", [], []) ; + Prim (loc, "PAIR", [], []) ]) in parse (i - 1) acc | _ -> assert false in match String.get str (len - 2) with | 'A' -> let init = Seq (loc, - [ Prim (loc, "DUP", [], None) ; - Prim (loc, "CDR", [], None) ; + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CDR", [], []) ; Prim (loc, "DIP", - [ Seq (loc, [ Prim (loc, "CAR", [], None) ; code ], None) ], None) ; - Prim (loc, "SWAP", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + [ Seq (loc, [ Prim (loc, "CAR", [], []) ; code ]) ], []) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], []) ]) in ok (Some (parse (len - 3) init)) | 'D' -> let init = Seq (loc, - [ Prim (loc, "DUP", [], None) ; - Prim (loc, "CDR", [], None) ; + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CDR", [], []) ; code ; - Prim (loc, "SWAP", [], None) ; - Prim (loc, "CAR", [], None) ; - Prim (loc, "PAIR", [], None) ], None) in + Prim (loc, "SWAP", [], []) ; + Prim (loc, "CAR", [], []) ; + Prim (loc, "PAIR", [], []) ]) in ok (Some (parse (len - 3) init)) | _ -> assert false else @@ -224,9 +224,9 @@ let expand_dxiiivp original = acc else make (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ], None)) in + (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in match args with - | [ Seq (_, _, _) as arg ] -> ok @@ Some (make depth arg) + | [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg) | [ _ ] -> error (Sequence_expected str) | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) with Not_a_roman -> ok None @@ -250,14 +250,14 @@ 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", [], if i = (len - 2) then annot else None) :: acc) + parse (i - 2) (Prim (loc, "PAIR", [], if i = (len - 2) then annot else []) :: acc) else if String.get str i = 'A' then match acc with | [] -> raise_notrace Not_a_pair | acc :: accs -> parse (i - 1) - (Prim (loc, "DIP", [ Seq (loc, [ acc ], None) ], None) + (Prim (loc, "DIP", [ Seq (loc, [ acc ]) ], []) :: accs) else raise_notrace Not_a_pair in @@ -266,7 +266,7 @@ let expand_paaiair original = | [] -> ok () | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) end >>? fun () -> - ok (Some (Seq (loc, expanded, None))) + ok (Some (Seq (loc, expanded))) with Not_a_pair -> ok None else ok None @@ -274,7 +274,7 @@ let expand_paaiair original = let expand_unpaaiair original = match original with - | Prim (loc, str, args, None) -> + | Prim (loc, str, args, []) -> let len = String.length str in if len >= 6 && String.sub str 0 3 = "UNP" @@ -286,16 +286,15 @@ let expand_unpaaiair original = if i = 2 then match acc with | [ Seq _ as acc ] -> acc - | _ -> Seq (loc, List.rev acc, None) + | _ -> Seq (loc, List.rev acc) else if String.get str i = 'I' && String.get str (i - 1) = 'A' then parse (i - 2) - (Seq (loc, [ Prim (loc, "DUP", [], None) ; - Prim (loc, "CAR", [], None) ; + (Seq (loc, [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CAR", [], []) ; Prim (loc, "DIP", [ Seq (loc, - [ Prim (loc, "CDR", [], None) ], - None) ], None) ], None) + [ Prim (loc, "CDR", [], []) ]) ], []) ]) :: acc) else if String.get str i = 'A' then match acc with @@ -303,12 +302,12 @@ let expand_unpaaiair original = raise_notrace Not_a_pair | (Seq _ as acc) :: accs -> parse (i - 1) - (Prim (loc, "DIP", [ acc ], None) :: accs) + (Prim (loc, "DIP", [ acc ], []) :: accs) | acc :: accs -> parse (i - 1) (Prim (loc, "DIP", - [ Seq (loc, [ acc ], None) ], - None) :: accs) + [ Seq (loc, [ acc ]) ], + []) :: accs) else raise_notrace Not_a_pair in let expanded = parse (len - 2) [] in @@ -341,11 +340,11 @@ let expand_duuuuup original = if i = 1 then acc else if String.get str i = 'U' then parse (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], None) ; - Prim (loc, "SWAP", [], None) ], None)) + (Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ; + Prim (loc, "SWAP", [], []) ])) else raise_notrace Not_a_dup in - ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ], None)))) + ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ])))) with Not_a_dup -> ok None else ok None @@ -354,88 +353,88 @@ let expand_duuuuup original = let expand_compare original = let cmp loc is = let is = - List.map (fun i -> Prim (loc, i, [], None)) is in - ok (Some (Seq (loc, is, None))) in + List.map (fun i -> Prim (loc, i, [], [])) is in + ok (Some (Seq (loc, is))) in let ifcmp loc is l r = let is = - List.map (fun i -> Prim (loc, i, [], None)) is @ - [ Prim (loc, "IF", [ l ; r ], None) ] in - ok (Some (Seq (loc, is, None))) in + List.map (fun i -> Prim (loc, i, [], [])) is @ + [ Prim (loc, "IF", [ l ; r ], []) ] in + ok (Some (Seq (loc, is))) in match original with - | Prim (loc, "CMPEQ", [], None) -> + | Prim (loc, "CMPEQ", [], []) -> cmp loc [ "COMPARE" ; "EQ" ] - | Prim (loc, "CMPNEQ", [], None) -> + | Prim (loc, "CMPNEQ", [], []) -> cmp loc [ "COMPARE" ; "NEQ" ] - | Prim (loc, "CMPLT", [], None) -> + | Prim (loc, "CMPLT", [], []) -> cmp loc [ "COMPARE" ; "LT" ] - | Prim (loc, "CMPGT", [], None) -> + | Prim (loc, "CMPGT", [], []) -> cmp loc [ "COMPARE" ; "GT" ] - | Prim (loc, "CMPLE", [], None) -> + | Prim (loc, "CMPLE", [], []) -> cmp loc [ "COMPARE" ; "LE" ] - | Prim (loc, "CMPGE", [], None) -> + | Prim (loc, "CMPGE", [], []) -> cmp loc [ "COMPARE" ; "GE" ] | Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT" - | "CMPGT" | "CMPLE" | "CMPGE" as str), args, None) -> + | "CMPGT" | "CMPLE" | "CMPGE" as str), args, []) -> error (Invalid_arity (str, List.length args, 0)) - | Prim (loc, "IFCMPEQ", [ l ; r ], None) -> + | Prim (loc, "IFCMPEQ", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "EQ" ] l r - | Prim (loc, "IFCMPNEQ", [ l ; r ], None) -> + | Prim (loc, "IFCMPNEQ", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "NEQ" ] l r - | Prim (loc, "IFCMPLT", [ l ; r ], None) -> + | Prim (loc, "IFCMPLT", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "LT" ] l r - | Prim (loc, "IFCMPGT", [ l ; r ], None) -> + | Prim (loc, "IFCMPGT", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "GT" ] l r - | Prim (loc, "IFCMPLE", [ l ; r ], None) -> + | Prim (loc, "IFCMPLE", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "LE" ] l r - | Prim (loc, "IFCMPGE", [ l ; r ], None) -> + | Prim (loc, "IFCMPGE", [ l ; r ], []) -> ifcmp loc [ "COMPARE" ; "GE" ] l r - | Prim (loc, "IFEQ", [ l ; r ], None) -> + | Prim (loc, "IFEQ", [ l ; r ], []) -> ifcmp loc [ "EQ" ] l r - | Prim (loc, "IFNEQ", [ l ; r ], None) -> + | Prim (loc, "IFNEQ", [ l ; r ], []) -> ifcmp loc [ "NEQ" ] l r - | Prim (loc, "IFLT", [ l ; r ], None) -> + | Prim (loc, "IFLT", [ l ; r ], []) -> ifcmp loc [ "LT" ] l r - | Prim (loc, "IFGT", [ l ; r ], None) -> + | Prim (loc, "IFGT", [ l ; r ], []) -> ifcmp loc [ "GT" ] l r - | Prim (loc, "IFLE", [ l ; r ], None) -> + | Prim (loc, "IFLE", [ l ; r ], []) -> ifcmp loc [ "LE" ] l r - | Prim (loc, "IFGE", [ l ; r ], None) -> + | Prim (loc, "IFGE", [ l ; r ], []) -> ifcmp loc [ "GE" ] l r | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" - | "IFGT" | "IFLE" | "IFGE" as str), args, None) -> + | "IFGT" | "IFLE" | "IFGE" as str), args, []) -> error (Invalid_arity (str, List.length args, 2)) | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" | "IFEQ" | "IFNEQ" | "IFLT" | "IFGT" | "IFLE" | "IFGE" | "CMPEQ" | "CMPNEQ" | "CMPLT" - | "CMPGT" | "CMPLE" | "CMPGE" as str), [], Some _) -> + | "CMPGT" | "CMPLE" | "CMPGE" as str), [], _ :: _) -> error (Unexpected_macro_annotation str) | _ -> ok None let expand_asserts original = let fail_false loc = - [ Seq(loc, [], None) ; Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ] in + [ Seq(loc, []) ; Seq(loc, [ Prim (loc, "FAIL", [], []) ]) ] in let fail_true loc = - [ Seq(loc, [ Prim (loc, "FAIL", [], None) ], None) ; Seq(loc, [], None) ] in + [ Seq(loc, [ Prim (loc, "FAIL", [], []) ]) ; Seq(loc, []) ] in match original with - | Prim (loc, "ASSERT", [], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, None) ], None)) - | Prim (loc, "ASSERT_NONE", [], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, None) ], None)) - | Prim (loc, "ASSERT_SOME", [], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, None) ], None)) - | Prim (loc, "ASSERT_LEFT", [], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, None) ], None)) - | Prim (loc, "ASSERT_RIGHT", [], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, None) ], None)) + | Prim (loc, "ASSERT", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ])) + | Prim (loc, "ASSERT_NONE", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ])) + | Prim (loc, "ASSERT_SOME", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true loc, []) ])) + | Prim (loc, "ASSERT_LEFT", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false loc, []) ])) + | Prim (loc, "ASSERT_RIGHT", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true loc, []) ])) | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" - | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, None) -> + | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, []) -> error (Invalid_arity (str, List.length args, 0)) | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" - | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], Some _) -> + | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), [], _ :: _) -> error (Unexpected_macro_annotation str) | Prim (loc, s, args, annot) when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> @@ -444,42 +443,42 @@ let expand_asserts original = | _ :: _ -> error (Invalid_arity (s, List.length args, 0)) end >>? fun () -> begin match annot with - | Some _ -> (error (Unexpected_macro_annotation s)) - | None -> ok () end >>? fun () -> + | _ :: _ -> (error (Unexpected_macro_annotation s)) + | [] -> ok () end >>? fun () -> begin let remaining = String.(sub s 7 ((length s) - 7)) in - let remaining_prim = Prim(loc, remaining, [], None) in + let remaining_prim = Prim (loc, remaining, [], []) in match remaining with | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> ok @@ Some (Seq (loc, [ remaining_prim ; - Prim (loc, "IF", fail_false loc, None) ], None)) + Prim (loc, "IF", fail_false loc, []) ])) | _ -> begin expand_compare remaining_prim >|? function | None -> None | Some seq -> Some (Seq (loc, [ seq ; - Prim (loc, "IF", fail_false loc, None) ], None)) + Prim (loc, "IF", fail_false loc, []) ])) end end | _ -> ok None let expand_if_some = function - | Prim (loc, "IF_SOME", [ right ; left ], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], None) ], None)) - | Prim (_, "IF_SOME", args, None) -> + | Prim (loc, "IF_SOME", [ right ; left ], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], []) ])) + | Prim (_, "IF_SOME", args, []) -> error (Invalid_arity ("IF_SOME", List.length args, 2)) - | Prim (_, "IF_SOME", [], Some _) -> + | Prim (_, "IF_SOME", [], _ :: _) -> error (Unexpected_macro_annotation "IF_SOME") | _ -> ok @@ None let expand_if_right = function - | Prim (loc, "IF_RIGHT", [ right ; left ], None) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], None) ], None)) - | Prim (_, "IF_RIGHT", args, None) -> + | Prim (loc, "IF_RIGHT", [ right ; left ], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], []) ])) + | Prim (_, "IF_RIGHT", args, []) -> error (Invalid_arity ("IF_RIGHT", List.length args, 2)) - | Prim (_, "IF_RIGHT", [], Some _) -> + | Prim (_, "IF_RIGHT", [], _ :: _) -> error (Unexpected_macro_annotation "IF_RIGHT") | _ -> ok @@ None @@ -517,9 +516,9 @@ let expand_rec expr = | Ok expanded -> begin match expanded with - | Seq (loc, items, annot) -> + | Seq (loc, items) -> let items, errors = error_map expand_rec items in - (Seq (loc, items, annot), errors) + (Seq (loc, items), errors) | Prim (loc, name, args, annot) -> let args, errors = error_map expand_rec args in (Prim (loc, name, args, annot), errors) @@ -530,18 +529,18 @@ let expand_rec expr = let unexpand_caddadr expanded = let rec rsteps acc = function | [] -> Some acc - | Prim (_, "CAR" , [], None) :: rest -> + | Prim (_, "CAR" , [], []) :: rest -> rsteps ("A" :: acc) rest - | Prim (_, "CDR" , [], None) :: rest -> + | Prim (_, "CDR" , [], []) :: rest -> rsteps ("D" :: acc) rest | _ -> None in match expanded with - | Seq (loc, (Prim (_, "CAR" , [], None) :: _ as nodes), None) - | Seq (loc, (Prim (_, "CDR" , [], None) :: _ as nodes), None) -> + | Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes)) + | Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) -> begin match rsteps [] nodes with | Some steps -> let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [], None)) + Some (Prim (loc, name, [], [])) | None -> None end | _ -> None @@ -549,82 +548,82 @@ let unexpand_caddadr expanded = let unexpand_set_caddadr expanded = let rec steps acc = function | Seq (loc, - [ Prim (_, "CDR", [], None) ; - Prim (_, "SWAP", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CDR", [], []) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], []) ]) -> Some (loc, "A" :: acc) | Seq (loc, - [ Prim (_, "CAR", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CAR", [], []) ; + Prim (_, "PAIR", [], []) ]) -> Some (loc, "D" :: acc) | Seq (_, - [ Prim (_, "DUP", [], None) ; + [ Prim (_, "DUP", [], []) ; Prim (_, "DIP", [ Seq (_, - [ Prim (_, "CAR", [], None) ; - sub ], None) ], None) ; - Prim (_, "CDR", [], None) ; - Prim (_, "SWAP", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CAR", [], []) ; + sub ]) ], []) ; + Prim (_, "CDR", [], []) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], []) ]) -> steps ("A" :: acc) sub | Seq (_, - [ Prim (_, "DUP", [], None) ; + [ Prim (_, "DUP", [], []) ; Prim (_, "DIP", [ Seq (_, - [ Prim (_, "CDR", [], None) ; - sub ], None) ], None) ; - Prim (_, "CAR", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CDR", [], []) ; + sub ]) ], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "PAIR", [], []) ]) -> steps ("D" :: acc) sub | _ -> None in match steps [] expanded with | Some (loc, steps) -> let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [], None)) + Some (Prim (loc, name, [], [])) | None -> None let unexpand_map_caddadr expanded = let rec steps acc = function | Seq (loc, - [ Prim (_, "DUP", [], None) ; - Prim (_, "CDR", [], None) ; - Prim (_, "SWAP", [], None) ; - Prim (_, "CAR", [], None) ; + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], []) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "CAR", [], []) ; code ; - Prim (_, "PAIR", [], None) ], None) -> + Prim (_, "PAIR", [], []) ]) -> Some (loc, "A" :: acc, code) | Seq (loc, - [ Prim (_, "DUP", [], None) ; - Prim (_, "CDR", [], None) ; + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], []) ; code ; - Prim (_, "SWAP", [], None) ; - Prim (_, "CAR", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + Prim (_, "SWAP", [], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "PAIR", [], []) ]) -> Some (loc, "D" :: acc, code) | Seq (_, - [ Prim (_, "DUP", [], None) ; + [ Prim (_, "DUP", [], []) ; Prim (_, "DIP", [ Seq (_, - [ Prim (_, "CAR", [], None) ; - sub ], None) ], None) ; - Prim (_, "CDR", [], None) ; - Prim (_, "SWAP", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CAR", [], []) ; + sub ]) ], []) ; + Prim (_, "CDR", [], []) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], []) ]) -> steps ("A" :: acc) sub | Seq (_, - [ Prim (_, "DUP", [], None) ; + [ Prim (_, "DUP", [], []) ; Prim (_, "DIP", [ Seq (_, - [ Prim (_, "CDR", [], None) ; - sub ], None) ], None) ; - Prim (_, "CAR", [], None) ; - Prim (_, "PAIR", [], None) ], None) -> + [ Prim (_, "CDR", [], []) ; + sub ]) ], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "PAIR", [], []) ]) -> steps ("D" :: acc) sub | _ -> None in match steps [] expanded with | Some (loc, steps, code) -> let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [ code ], None)) + Some (Prim (loc, name, [ code ], [])) | None -> None let roman_of_decimal decimal = @@ -658,23 +657,22 @@ let unexpand_dxiiivp expanded = match expanded with | Seq (loc, [ Prim (_, "DIP", - [ Seq (_, [ Prim (_, "DIP", [ _ ], None) ], None) as sub ], - None) ], - None) -> + [ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ], + []) ]) -> let rec count acc = function - | Seq (_, [ Prim (_, "DIP", [ sub ], None) ], None) -> count (acc + 1) sub + | Seq (_, [ Prim (_, "DIP", [ sub ], []) ]) -> count (acc + 1) sub | sub -> (acc, sub) in let depth, sub = count 1 sub in let name = "D" ^ roman_of_decimal depth ^ "P" in - Some (Prim (loc, name, [ sub ], None)) + Some (Prim (loc, name, [ sub ], [])) | _ -> None let unexpand_duuuuup expanded = let rec help expanded = match expanded with - | Seq (loc, [ Prim (_, "DUP", [], None) ], None) -> Some (loc, 1) - | Seq (_, [ Prim (_, "DIP", [expanded'], None); - Prim (_, "SWAP", [], None) ], None) -> + | Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1) + | Seq (_, [ Prim (_, "DIP", [expanded'], []); + Prim (_, "SWAP", [], []) ]) -> begin match help expanded' with | None -> None @@ -686,158 +684,157 @@ let unexpand_duuuuup expanded = | n -> "U" ^ (dupn (n - 1)) in match help expanded with | None -> None - | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], None)) + | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], [])) let unexpand_paaiair expanded = match expanded with - | Seq (_, [ Prim (_, "PAIR", [], None) ], None) -> Some expanded - | Seq (loc, (_ :: _ as nodes), None) -> + | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded + | Seq (loc, (_ :: _ as nodes)) -> let rec destruct acc = function | [] -> Some acc - | Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest -> + | Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest -> destruct ("A" :: acc) (sub :: rest) - | Prim (_, "PAIR", [], None) :: rest -> + | Prim (_, "PAIR", [], []) :: rest -> destruct ("AI" :: acc) rest | _ -> None in begin match destruct [] nodes with | None -> None | Some seq -> let name = String.concat "" ("P" :: List.rev ("R" :: seq)) in - Some (Prim (loc, name, [], None)) + Some (Prim (loc, name, [], [])) end | _ -> None let unexpand_unpaaiair expanded = match expanded with - | Seq (loc, (_ :: _ as nodes), None) -> + | Seq (loc, (_ :: _ as nodes)) -> let rec destruct sacc acc = function | [] -> Some acc - | Prim (_, "DIP", [ Seq (_, [ sub ], None) ], None) :: rest - | Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest -> + | Prim (_, "DIP", [ Seq (_, [ sub ]) ], []) :: rest + | Prim (_, "DIP", [ Seq (_, _) as sub ], []) :: rest -> destruct ("A" :: sacc) acc (sub :: rest) - | Seq (_, [ Prim (_, "DUP", [], None) ; - Prim (_, "CAR", [], None) ; + | Seq (_, [ Prim (_, "DUP", [], []) ; + Prim (_, "CAR", [], []) ; Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], None) ], None) ], - None) ], None) :: rest -> + [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], + []) ]) :: rest -> destruct [] (List.rev ("AI" :: sacc) :: acc) rest | _ -> None in begin match destruct [] [ [ "R" ] ] nodes with | None -> None | Some seq -> let name = String.concat "" ("UNP" :: List.flatten seq) in - Some (Prim (loc, name, [], None)) + Some (Prim (loc, name, [], [])) end | _ -> None let unexpand_compare expanded = match expanded with - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "EQ", [], None) ], None) -> - Some (Prim (loc, "CMPEQ", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "NEQ", [], None) ], None) -> - Some (Prim (loc, "CMPNEQ", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "LT", [], None) ], None) -> - Some (Prim (loc, "CMPLT", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "GT", [], None) ], None) -> - Some (Prim (loc, "CMPGT", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "LE", [], None) ], None) -> - Some (Prim (loc, "CMPLE", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "GE", [], None) ], None) -> - Some (Prim (loc, "CMPGE", [], None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "EQ", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPEQ", args, None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "NEQ", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPNEQ", args, None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "LT", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPLT", args, None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "GT", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPGT", args, None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "LE", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPLE", args, None)) - | Seq (loc, [ Prim (_, "COMPARE", [], None) ; - Prim (_, "GE", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFCMPGE", args, None)) - | Seq (loc, [ Prim (_, "EQ", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFEQ", args, None)) - | Seq (loc, [ Prim (_, "NEQ", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFNEQ", args, None)) - | Seq (loc, [ Prim (_, "LT", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFLT", args, None)) - | Seq (loc, [ Prim (_, "GT", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFGT", args, None)) - | Seq (loc, [ Prim (_, "LE", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFLE", args, None)) - | Seq (loc, [ Prim (_, "GE", [], None) ; - Prim (_, "IF", args, None) ], None) -> - Some (Prim (loc, "IFGE", args, None)) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "EQ", [], []) ]) -> + Some (Prim (loc, "CMPEQ", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "NEQ", [], []) ]) -> + Some (Prim (loc, "CMPNEQ", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "LT", [], []) ]) -> + Some (Prim (loc, "CMPLT", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "GT", [], []) ]) -> + Some (Prim (loc, "CMPGT", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "LE", [], []) ]) -> + Some (Prim (loc, "CMPLE", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "GE", [], []) ]) -> + Some (Prim (loc, "CMPGE", [], [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "EQ", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPEQ", args, [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "NEQ", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPNEQ", args, [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "LT", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPLT", args, [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "GT", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPGT", args, [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "LE", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPLE", args, [])) + | Seq (loc, [ Prim (_, "COMPARE", [], []) ; + Prim (_, "GE", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFCMPGE", args, [])) + | Seq (loc, [ Prim (_, "EQ", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFEQ", args, [])) + | Seq (loc, [ Prim (_, "NEQ", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFNEQ", args, [])) + | Seq (loc, [ Prim (_, "LT", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFLT", args, [])) + | Seq (loc, [ Prim (_, "GT", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFGT", args, [])) + | Seq (loc, [ Prim (_, "LE", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFLE", args, [])) + | Seq (loc, [ Prim (_, "GE", [], []) ; + Prim (_, "IF", args, []) ]) -> + Some (Prim (loc, "IFGE", args, [])) | _ -> None let unexpand_asserts expanded = match expanded with - | Seq (loc, [ Prim (_, "IF", [ Seq (_, [ ], None) ; - Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT", [], None)) - | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], None) ; Prim(_, comparison, [], None) ], None) ; - Prim (_, "IF", [ Seq (_, [ ], None) ; - Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], None)) - | Seq (loc, [ Prim (_, comparison, [], None) ; - Prim (_, "IF", [ Seq (_, [ ], None) ; - Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT_" ^ comparison, [], None)) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ ], None) ; - Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT_NONE", [], None)) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ; - Seq (_, [ ], None)], - None) ], None) -> - Some (Prim (loc, "ASSERT_SOME", [], None)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ ], None) ; - Seq (_, [ Prim(_, "FAIL", [], None) ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT_LEFT", [], None)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim(_, "FAIL", [], None) ], None) ; - Seq (_, [ ], None) ], - None) ], None) -> - Some (Prim (loc, "ASSERT_RIGHT", [], None)) + | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ Prim(_, "FAIL", [], []) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT", [], [])) + | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ; + Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], [])) + | Seq (loc, [ Prim (_, comparison, [], []) ; + Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_" ^ comparison, [], [])) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ; + Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_NONE", [], [])) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ; + Seq (_, [])], + []) ]) -> + Some (Prim (loc, "ASSERT_SOME", [], [])) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ; + Seq (_, [ Prim (_, "FAIL", [], []) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_LEFT", [], [])) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "FAIL", [], []) ]) ; + Seq (_, []) ], + []) ]) -> + Some (Prim (loc, "ASSERT_RIGHT", [], [])) | _ -> None let unexpand_if_some = function - | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], None) ], None) -> - Some (Prim (loc, "IF_SOME", [ right ; left ], None)) + | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], []) ]) -> + Some (Prim (loc, "IF_SOME", [ right ; left ], [])) | _ -> None let unexpand_if_right = function - | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], None) ], None) -> - Some (Prim (loc, "IF_RIGHT", [ right ; left ], None)) + | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], []) ]) -> + Some (Prim (loc, "IF_RIGHT", [ right ; left ], [])) | _ -> None let unexpand original = @@ -866,8 +863,8 @@ let unexpand original = let rec unexpand_rec expr = match unexpand expr with - | Seq (loc, items, annot) -> - Seq (loc, List.map unexpand_rec items, annot) + | Seq (loc, items) -> + Seq (loc, List.map unexpand_rec items) | Prim (loc, name, args, annot) -> Prim (loc, name, List.map unexpand_rec args, annot) | Int _ | String _ as atom -> atom diff --git a/src/proto_alpha/lib_client/michelson_v1_parser.ml b/src/proto_alpha/lib_client/michelson_v1_parser.ml index 69be0c3fa..5bf0b0f0a 100644 --- a/src/proto_alpha/lib_client/michelson_v1_parser.ml +++ b/src/proto_alpha/lib_client/michelson_v1_parser.ml @@ -54,7 +54,7 @@ let expand_all source ast errors = errors @ expansion_errors | Error errs -> { source ; unexpanded ; - expanded = Micheline.strip_locations (Seq ((), [], None)) ; + expanded = Micheline.strip_locations (Seq ((), [])) ; expansion_table ; unexpansion_table }, errors @ expansion_errors @ errs @@ -63,7 +63,7 @@ let parse_toplevel ?check source = 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, None) in + Seq ({ start ; stop }, asts) in expand_all source ast (lexing_errors @ parsing_errors) let parse_expression ?check source = diff --git a/src/proto_alpha/lib_client/michelson_v1_printer.ml b/src/proto_alpha/lib_client/michelson_v1_printer.ml index 05de8a82c..1ee045a31 100644 --- a/src/proto_alpha/lib_client/michelson_v1_printer.ml +++ b/src/proto_alpha/lib_client/michelson_v1_printer.ml @@ -37,8 +37,8 @@ let print_stack ppf = function let inject_types type_map parsed = let rec inject_expr = function - | Seq (loc, items, annot) -> - Seq (inject_loc `before loc, List.map inject_expr items, annot) + | Seq (loc, items) -> + Seq (inject_loc `before loc, List.map inject_expr items) | Prim (loc, name, items, annot) -> Prim (inject_loc `after loc, name, List.map inject_expr items, annot) | Int (loc, value) -> @@ -69,8 +69,8 @@ let unparse ?type_map parse expanded = |> Michelson_v1_primitives.strings_of_prims |> root |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations in let rec inject_expr = function - | Seq (loc, items, annot) -> - Seq (inject_loc `before loc, List.map inject_expr items, annot) + | Seq (loc, items) -> + Seq (inject_loc `before loc, List.map inject_expr items) | Prim (loc, name, items, annot) -> Prim (inject_loc `after loc, name, List.map inject_expr items, annot) | Int (loc, value) -> diff --git a/src/proto_alpha/lib_protocol/src/apply.ml b/src/proto_alpha/lib_protocol/src/apply.ml index ed94e7d37..96b2db80d 100644 --- a/src/proto_alpha/lib_protocol/src/apply.ml +++ b/src/proto_alpha/lib_protocol/src/apply.ml @@ -373,7 +373,7 @@ let apply_manager_operation_content : begin match parameters with | None -> (* Forge a [Unit] parameter that will be checked by [execute]. *) - let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)) in + let unit = Micheline.strip_locations (Prim (0, Script.D_Unit, [], [])) in return (ctxt, unit) | Some parameters -> Lwt.return (Script.force_decode parameters) >>=? fun arg -> diff --git a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml index 33287f330..017f1fe61 100644 --- a/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/src/michelson_v1_primitives.ml @@ -369,14 +369,14 @@ let prims_of_strings expr = ok (arg :: args)) (ok []) args >>? fun args -> ok (Prim (0, prim, List.rev args, annot)) - | Seq (_, args, annot) -> + | Seq (_, args) -> List.fold_left (fun acc arg -> acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args)) (ok []) args >>? fun args -> - ok (Seq (0, List.rev args, annot)) in + ok (Seq (0, List.rev args)) in convert (root expr) >>? fun expr -> ok (strip_locations expr) @@ -387,9 +387,9 @@ let strings_of_prims expr = let prim = string_of_prim prim in let args = List.map convert args in Prim (0, prim, args, annot) - | Seq (_, args, annot) -> + | Seq (_, args) -> let args = List.map convert args in - Seq (0, args, annot) in + Seq (0, args) in strip_locations (convert (root expr)) let prim_encoding = diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml index 0f7c7a6e8..6d661636b 100644 --- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml +++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml @@ -634,9 +634,9 @@ let rec interp Lwt.return (Gas.consume ctxt Interp_costs.create_contract) >>=? fun ctxt -> let code = Micheline.strip_locations - (Seq (0, [ Prim (0, K_parameter, [ unparse_ty None param_type ], None) ; - Prim (0, K_storage, [ unparse_ty None storage_type ], None) ; - Prim (0, K_code, [ Micheline.root code ], None) ], None)) in + (Seq (0, [ Prim (0, K_parameter, [ unparse_ty [] param_type ], []) ; + Prim (0, K_storage, [ unparse_ty [] storage_type ], []) ; + Prim (0, K_code, [ Micheline.root code ], []) ])) in unparse_data ctxt Optimized storage_type init >>=? fun (storage, ctxt) -> let storage = Micheline.strip_locations storage in Contract.spend_from_script ctxt self credit >>=? fun ctxt -> diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml index ad2cc507b..a32eb1172 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.ml +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.ml @@ -29,12 +29,12 @@ let add_dip ty annot prev = | Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev) | Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev) -let default_param_annot = Some "@parameter" -let default_storage_annot = Some "@storage" -let default_arg_annot = Some "@arg" +let default_param_annot = [ "@parameter" ] +let default_storage_annot = [ "@storage" ] +let default_arg_annot = [ "@arg" ] let default_annot ~default = function - | None -> default + | [] -> default | annot -> annot (* ---- Type size accounting ------------------------------------------------*) @@ -216,7 +216,7 @@ let location = function | Prim (loc, _, _, _) | Int (loc, _) | String (loc, _) - | Seq (loc, _, _) -> loc + | Seq (loc, _) -> loc let kind = function | Int _ -> Int_kind @@ -335,7 +335,7 @@ let unexpected expr exp_kinds exp_ns exp_prims = match expr with | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) | String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) - | Seq (loc, _, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) + | Seq (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) | Prim (loc, name, _, _) -> match namespace name, exp_ns with | Type_namespace, Type_namespace @@ -505,14 +505,14 @@ let ty_of_comparable_ty let unparse_comparable_ty : type a. a comparable_ty -> Script.node = function - | Int_key -> Prim (-1, T_int, [], None) - | Nat_key -> Prim (-1, T_nat, [], None) - | String_key -> Prim (-1, T_string, [], None) - | Mutez_key -> Prim (-1, T_mutez, [], None) - | Bool_key -> Prim (-1, T_bool, [], None) - | Key_hash_key -> Prim (-1, T_key_hash, [], None) - | Timestamp_key -> Prim (-1, T_timestamp, [], None) - | Address_key -> Prim (-1, T_address, [], None) + | Int_key -> Prim (-1, T_int, [], []) + | Nat_key -> Prim (-1, T_nat, [], []) + | String_key -> Prim (-1, T_string, [], []) + | Mutez_key -> Prim (-1, T_mutez, [], []) + | Bool_key -> Prim (-1, T_bool, [], []) + | Key_hash_key -> Prim (-1, T_key_hash, [], []) + | Timestamp_key -> Prim (-1, T_timestamp, [], []) + | Address_key -> Prim (-1, T_address, [], []) let rec unparse_ty : type a. annot -> a ty -> Script.node = fun annot -> @@ -530,7 +530,7 @@ let rec unparse_ty | Signature_t -> Prim (-1, T_signature, [], annot) | Operation_t -> Prim (-1, T_operation, [], annot) | Contract_t ut -> - let t = unparse_ty None ut in + let t = unparse_ty [] ut in Prim (-1, T_contract, [ t ], annot) | Pair_t ((utl, left_annot), (utr, right_annot)) -> let tl = unparse_ty left_annot utl in @@ -541,26 +541,26 @@ let rec unparse_ty let tr = unparse_ty right_annot utr in Prim (-1, T_or, [ tl; tr ], annot) | Lambda_t (uta, utr) -> - let ta = unparse_ty None uta in - let tr = unparse_ty None utr in + let ta = unparse_ty [] uta in + let tr = unparse_ty [] utr in Prim (-1, T_lambda, [ ta; tr ], annot) | Option_t ut -> - let t = unparse_ty None ut in + let t = unparse_ty [] ut in Prim (-1, T_option, [ t ], annot) | List_t ut -> - let t = unparse_ty None ut in + let t = unparse_ty [] ut in Prim (-1, T_list, [ t ], annot) | Set_t ut -> let t = unparse_comparable_ty ut in - Prim (-1, T_set, [ t ], None) + Prim (-1, T_set, [ t ], []) | Map_t (uta, utr) -> let ta = unparse_comparable_ty uta in - let tr = unparse_ty None utr in - Prim (-1, T_map, [ ta; tr ], None) + let tr = unparse_ty [] utr in + Prim (-1, T_map, [ ta; tr ], []) | Big_map_t (uta, utr) -> let ta = unparse_comparable_ty uta in - let tr = unparse_ty None utr in - Prim (-1, T_big_map, [ ta; tr ], None) + let tr = unparse_ty [] utr in + Prim (-1, T_big_map, [ ta; tr ], []) (* ---- Equality witnesses --------------------------------------------------*) @@ -653,14 +653,16 @@ let rec stack_ty_eq | Empty_t, Empty_t -> Ok Eq | _, _ -> error Bad_stack_length +module CompareStringList = Compare.List (Compare.String) + let merge_annot annot1 annot2 = match annot1, annot2 with - | None, None - | Some _, None - | None, Some _ -> ok None - | Some annot1, Some annot2 -> - if String.equal annot1 annot2 - then ok (Some annot1) + | [], [] + | _ :: _, [] + | [], _ :: _ -> ok [] + | annot1, annot2 -> + if CompareStringList.equal annot1 annot2 + then ok annot1 else error (Inconsistent_annotations (annot1, annot2)) let merge_comparable_types @@ -680,14 +682,14 @@ let merge_comparable_types let error_unexpected_annot loc annot = match annot with - | None -> ok () - | Some _ -> error (Unexpected_annotation loc) + | [] -> ok () + | _ :: _ -> error (Unexpected_annotation loc) let rec strip_annotations = function | (Int (_,_) as i) -> i | (String (_,_) as s) -> s - | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, None) - | Seq (loc, items, _) -> Seq (loc, List.map strip_annotations items, None) + | Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, []) + | Seq (loc, items) -> Seq (loc, List.map strip_annotations items) let fail_unexpected_annot loc annot = Lwt.return (error_unexpected_annot loc annot) @@ -1201,7 +1203,7 @@ let rec parse_data | Lambda_t (ta, tr), (Seq _ as script_instr) -> Lwt.return (Gas.consume ctxt Typecheck_costs.lambda) >>=? fun ctxt -> traced @@ - parse_returning Lambda ?type_logger ctxt (ta, Some "@arg") tr script_instr + parse_returning Lambda ?type_logger ctxt (ta, [ "@arg" ]) tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) @@ -1220,8 +1222,7 @@ let rec parse_data | Option_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ D_Some ; D_None ])) (* Lists *) - | List_t t, Seq (loc, items, annot) -> - fail_unexpected_annot loc annot >>=? fun () -> + | List_t t, Seq (_, items) -> traced @@ fold_right_s (fun v (rest, ctxt) -> @@ -1232,8 +1233,7 @@ let rec parse_data | List_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Sets *) - | Set_t t, (Seq (loc, vs, annot) as expr) -> - fail_unexpected_annot loc annot >>=? fun () -> + | Set_t t, (Seq (loc, vs) as expr) -> traced @@ fold_left_s (fun (last_value, set, ctxt) v -> @@ -1256,13 +1256,11 @@ let rec parse_data | Set_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Maps *) - | Map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> - fail_unexpected_annot loc annot >>=? fun () -> + | Map_t (tk, tv), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x) | Map_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) - | Big_map_t (tk, tv), (Seq (loc, vs, annot) as expr) -> - fail_unexpected_annot loc annot >>=? fun () -> + | Big_map_t (tk, tv), (Seq (loc, vs) as expr) -> parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x) >>|? fun (diff, ctxt) -> ({ diff ; key_type = ty_of_comparable_ty tk ; value_type = tv }, ctxt) | Big_map_t (_tk, _tv), expr -> @@ -1291,7 +1289,7 @@ and parse_returning | (Typed { loc ; aft = stack_ty ; _ }, _gas) -> fail (Bad_return (loc, stack_ty, ret)) | (Failed { descr }, gas) -> - return ((Lam (descr (Item_t (ret, Empty_t, None)), strip_locations script_instr) + return ((Lam (descr (Item_t (ret, Empty_t, [])), strip_locations script_instr) : (arg, ret) lambda), gas) and parse_instr @@ -1316,7 +1314,7 @@ and parse_instr return (judgement, ctxt) in let keep_or_rewrite_annot value_annot instr_annot = match value_annot, instr_annot with - | annot, None -> annot + | annot, [] -> annot | _, annot -> annot in let check_item check loc name n m = trace (Bad_stack (loc, name, m, stack_ty)) @@ @@ -1327,7 +1325,7 @@ and parse_instr let typed ctxt loc instr aft = begin match type_logger, script_instr with | None, _ - | Some _, (Seq (-1, _, _) | Int _ | String _) -> () + | Some _, (Seq (-1, _) | Int _ | String _) -> () | Some log, (Prim _ | Seq _) -> log loc (unparse_stack stack_ty) (unparse_stack aft) end ; @@ -1398,12 +1396,12 @@ and parse_instr Item_t (tl, rest, stack_annot) -> (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tr)) >>=? fun (Ex_ty tr, _) -> typed ctxt loc Left - (Item_t (Union_t ((tl, stack_annot), (tr, None)), rest, instr_annot)) + (Item_t (Union_t ((tl, stack_annot), (tr, [])), rest, instr_annot)) | Prim (loc, I_RIGHT, [ tl ], instr_annot), Item_t (tr, rest, stack_annot) -> (Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true tl)) >>=? fun (Ex_ty tl, _) -> typed ctxt loc Right - (Item_t (Union_t ((tl, None), (tr, stack_annot)), rest, instr_annot)) + (Item_t (Union_t ((tl, []), (tr, stack_annot)), rest, instr_annot)) | Prim (loc, I_IF_LEFT, [ bt ; bf ], instr_annot), (Item_t (Union_t ((tl, left_annot), (tr, right_annot)), rest, _) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> @@ -1446,7 +1444,7 @@ and parse_instr (Item_t (List_t elt, starting_rest, _)) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_instr ?type_logger tc_context ctxt - body (Item_t (elt, starting_rest, None)) >>=? begin fun (judgement, ctxt) -> + body (Item_t (elt, starting_rest, [])) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> trace @@ -1462,7 +1460,7 @@ and parse_instr check_kind [ Seq_kind ] body >>=? fun () -> fail_unexpected_annot loc instr_annot >>=? fun () -> parse_instr ?type_logger tc_context ctxt - body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> + body (Item_t (elt, rest, [])) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace @@ -1484,7 +1482,7 @@ and parse_instr fail_unexpected_annot loc annot >>=? fun () -> let elt = ty_of_comparable_ty comp_elt in parse_instr ?type_logger tc_context ctxt - body (Item_t (elt, rest, None)) >>=? begin fun (judgement, ctxt) -> + body (Item_t (elt, rest, [])) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace @@ -1522,7 +1520,7 @@ and parse_instr let k = ty_of_comparable_ty ck in check_kind [ Seq_kind ] body >>=? fun () -> parse_instr ?type_logger tc_context ctxt - body (Item_t (Pair_t ((k, None), (elt, None)), starting_rest, None)) >>=? begin fun (judgement, ctxt) -> + body (Item_t (Pair_t ((k, []), (elt, [])), starting_rest, [])) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft = Item_t (ret, rest, _) ; _ } as ibody) -> trace @@ -1539,7 +1537,7 @@ and parse_instr fail_unexpected_annot loc instr_annot >>=? fun () -> let key = ty_of_comparable_ty comp_elt in parse_instr ?type_logger tc_context ctxt body - (Item_t (Pair_t ((key, None), (element_ty, None)), rest, None)) + (Item_t (Pair_t ((key, []), (element_ty, [])), rest, [])) >>=? begin fun (judgement, ctxt) -> match judgement with | Typed ({ aft ; _ } as ibody) -> trace @@ -1593,13 +1591,11 @@ and parse_instr typed ctxt loc Big_map_update (Item_t (Big_map_t (map_key, map_value), rest, instr_annot)) (* control *) - | Seq (loc, [], annot), + | Seq (loc, []), stack -> - fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Nop stack - | Seq (loc, [ single ], annot), + | Seq (loc, [ single ]), stack -> - fail_unexpected_annot loc annot >>=? fun () -> parse_instr ?type_logger tc_context ctxt single stack >>=? begin fun (judgement, ctxt) -> match judgement with @@ -1613,16 +1609,15 @@ and parse_instr { descr with instr = Seq (descr, nop) } in return ctxt (Failed { descr }) end - | Seq (loc, hd :: tl, annot), + | Seq (loc, hd :: tl), stack -> - fail_unexpected_annot loc annot >>=? fun () -> parse_instr ?type_logger tc_context ctxt hd stack >>=? begin fun (judgement, ctxt) -> match judgement with | Failed _ -> fail (Fail_not_in_tail_position (Micheline.location hd)) | Typed ({ aft = middle ; _ } as ihd) -> - parse_instr ?type_logger tc_context ctxt (Seq (-1, tl, None)) + parse_instr ?type_logger tc_context ctxt (Seq (-1, tl)) middle >>=? fun (judgement, ctxt) -> match judgement with | Failed { descr } -> @@ -1672,7 +1667,7 @@ and parse_instr (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun Eq -> typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot)) | Failed { descr } -> - let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, None)) in + let ibody = descr (Item_t (Union_t ((tl, tl_annot), (tr, tr_annot)), rest, [])) in typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, tr_annot)) end | Prim (loc, I_LAMBDA, [ arg ; ret ; code ], instr_annot), @@ -1767,11 +1762,11 @@ and parse_instr Item_t (Int_t, rest, _) -> typed ctxt loc Abs_int (Item_t (Nat_t, rest, instr_annot)) - | Prim (loc, I_ISNAT, [], Some instr_annot), - Item_t (Int_t, rest, None) -> + | Prim (loc, I_ISNAT, [], (_ :: _ as instr_annot)), + Item_t (Int_t, rest, []) -> typed ctxt loc Is_nat - (Item_t (Option_t Nat_t, rest, Some instr_annot)) - | Prim (loc, I_ISNAT, [], None), + (Item_t (Option_t Nat_t, rest, instr_annot)) + | Prim (loc, I_ISNAT, [], []), Item_t (Int_t, rest, annot) -> typed ctxt loc Is_nat (Item_t (Option_t Nat_t, rest, annot)) @@ -1838,27 +1833,27 @@ and parse_instr | Prim (loc, I_EDIV, [], instr_annot), Item_t (Mutez_t, Item_t (Nat_t, rest, _), _) -> typed ctxt loc Ediv_teznat - (Item_t (Option_t (Pair_t ((Mutez_t, None), (Mutez_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Mutez_t, []), (Mutez_t, []))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Mutez_t, Item_t (Mutez_t, rest, _), _) -> typed ctxt loc Ediv_tez - (Item_t (Option_t (Pair_t ((Nat_t, None), (Mutez_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Nat_t, []), (Mutez_t, []))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Int_t, Item_t (Int_t, rest, _), _) -> typed ctxt loc Ediv_intint - (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Int_t, Item_t (Nat_t, rest, _), _) -> typed ctxt loc Ediv_intnat - (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Nat_t, Item_t (Int_t, rest, _), _) -> typed ctxt loc Ediv_natint - (Item_t (Option_t (Pair_t ((Int_t, None), (Nat_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Int_t, []), (Nat_t, []))), rest, instr_annot)) | Prim (loc, I_EDIV, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> typed ctxt loc Ediv_natnat - (Item_t (Option_t (Pair_t ((Nat_t, None), (Nat_t, None))), rest, instr_annot)) + (Item_t (Option_t (Pair_t ((Nat_t, []), (Nat_t, []))), rest, instr_annot)) | Prim (loc, I_LSL, [], instr_annot), Item_t (Nat_t, Item_t (Nat_t, rest, _), _) -> typed ctxt loc Lsl_nat @@ -1984,12 +1979,12 @@ and parse_instr (Bool_t, Item_t (Mutez_t, rest, _), _), _), _) -> typed ctxt loc Create_account - (Item_t (Operation_t, Item_t (Address_t, rest, None), instr_annot)) + (Item_t (Operation_t, Item_t (Address_t, rest, []), instr_annot)) | Prim (loc, I_IMPLICIT_ACCOUNT, [], instr_annot), Item_t (Key_hash_t, rest, _) -> typed ctxt loc Implicit_account (Item_t (Contract_t Unit_t, rest, instr_annot)) - | Prim (loc, I_CREATE_CONTRACT, [ (Seq (seq_loc, _, annot) as code)], instr_annot), + | Prim (loc, I_CREATE_CONTRACT, [ (Seq (_, _) as code)], instr_annot), Item_t (Key_hash_t, Item_t (Option_t Key_hash_t, Item_t @@ -1997,7 +1992,6 @@ and parse_instr (Bool_t, Item_t (Mutez_t, Item_t (ginit, rest, _), _), _), _), _), _) -> - fail_unexpected_annot seq_loc annot >>=? fun () -> let cannonical_code = fst @@ Micheline.extract_locations code in Lwt.return (parse_toplevel cannonical_code) >>=? fun (arg_type, storage_type, code_field) -> trace @@ -2010,18 +2004,18 @@ and parse_instr >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in - let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in + let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in trace (Ill_typed_contract (cannonical_code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? + ctxt ?type_logger (arg_type_full, []) ret_type_full code_field) >>=? fun (Lam ({ bef = Item_t (arg, Empty_t, _) ; aft = Item_t (ret, Empty_t, _) ; _ }, _) as lambda, ctxt) -> Lwt.return @@ ty_eq arg arg_type_full >>=? fun Eq -> Lwt.return @@ ty_eq ret ret_type_full >>=? fun Eq -> Lwt.return @@ ty_eq storage_type ginit >>=? fun Eq -> typed ctxt loc (Create_contract (storage_type, arg_type, lambda)) - (Item_t (Operation_t, Item_t (Address_t, rest, None), instr_annot)) + (Item_t (Operation_t, Item_t (Address_t, rest, []), instr_annot)) | Prim (loc, I_NOW, [], instr_annot), stack -> typed ctxt loc Now @@ -2187,13 +2181,13 @@ and parse_toplevel | Int (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], Int_kind)) | String (loc, _) -> error (Invalid_kind (loc, [ Seq_kind ], String_kind)) | Prim (loc, _, _, _) -> error (Invalid_kind (loc, [ Seq_kind ], Prim_kind)) - | Seq (_, fields, _) -> + | Seq (_, fields) -> let rec find_fields p s c fields = match fields with | [] -> ok (p, s, c) | Int (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Int_kind)) | String (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], String_kind)) - | Seq (loc, _, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) + | Seq (loc, _) :: _ -> error (Invalid_kind (loc, [ Prim_kind ], Seq_kind)) | Prim (loc, K_parameter, [ arg ], _) :: rest -> begin match p with | None -> find_fields (Some arg) s c rest @@ -2238,14 +2232,14 @@ let parse_script >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in - let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in + let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in trace (Ill_typed_data (None, storage, storage_type)) (parse_data ?type_logger ctxt storage_type (root storage)) >>=? fun (storage, ctxt) -> trace (Ill_typed_contract (code, [])) (parse_returning (Toplevel { storage_type ; param_type = arg_type }) - ctxt ?type_logger (arg_type_full, None) ret_type_full code_field) >>=? fun (code, ctxt) -> + ctxt ?type_logger (arg_type_full, []) ret_type_full code_field) >>=? fun (code, ctxt) -> return (Ex_script { code ; arg_type ; storage ; storage_type }, ctxt) let typecheck_code @@ -2264,13 +2258,13 @@ let typecheck_code >>=? fun (Ex_ty storage_type, storage_annot) -> let arg_type_full = Pair_t ((arg_type, default_annot ~default:default_param_annot param_annot), (storage_type, default_annot ~default:default_storage_annot storage_annot)) in - let ret_type_full = Pair_t ((List_t Operation_t, None), (storage_type, None)) in + let ret_type_full = Pair_t ((List_t Operation_t, []), (storage_type, [])) in let result = parse_returning (Toplevel { storage_type ; param_type = arg_type }) ctxt ~type_logger: (fun loc bef aft -> type_map := (loc, (bef, aft)) :: !type_map) - (arg_type_full, None) ret_type_full code_field in + (arg_type_full, []) ret_type_full code_field in trace (Ill_typed_contract (code, !type_map)) result >>=? fun (Lam _, ctxt) -> @@ -2303,7 +2297,7 @@ let rec unparse_data match ty, a with | Unit_t, () -> Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt -> - return (Prim (-1, D_Unit, [], None), ctxt) + return (Prim (-1, D_Unit, [], []), ctxt) | Int_t, v -> Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt) @@ -2315,10 +2309,10 @@ let rec unparse_data return (String (-1, s), ctxt) | Bool_t, true -> Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_True, [], None), ctxt) + return (Prim (-1, D_True, [], []), ctxt) | Bool_t, false -> Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt -> - return (Prim (-1, D_False, [], None), ctxt) + return (Prim (-1, D_False, [], []), ctxt) | Timestamp_t, t -> Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt -> begin @@ -2389,22 +2383,22 @@ let rec unparse_data Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Pair, [ l; r ], None), ctxt) + return (Prim (-1, D_Pair, [ l; r ], []), ctxt) | Union_t ((tl, _), _), L l -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tl l >>=? fun (l, ctxt) -> - return (Prim (-1, D_Left, [ l ], None), ctxt) + return (Prim (-1, D_Left, [ l ], []), ctxt) | Union_t (_, (tr, _)), R r -> Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt -> unparse_data ctxt mode tr r >>=? fun (r, ctxt) -> - return (Prim (-1, D_Right, [ r ], None), ctxt) + return (Prim (-1, D_Right, [ r ], []), ctxt) | Option_t t, Some v -> Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt -> unparse_data ctxt mode t v >>=? fun (v, ctxt) -> - return (Prim (-1, D_Some, [ v ], None), ctxt) + return (Prim (-1, D_Some, [ v ], []), ctxt) | Option_t _, None -> Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt -> - return (Prim (-1, D_None, [], None), ctxt) + return (Prim (-1, D_None, [], []), ctxt) | List_t t, items -> fold_left_s (fun (l, ctxt) element -> @@ -2413,7 +2407,7 @@ let rec unparse_data return (unparsed :: l, ctxt)) ([], ctxt) items >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, List.rev items, None), ctxt) + return (Micheline.Seq (-1, List.rev items), ctxt) | Set_t t, set -> let t = ty_of_comparable_ty t in fold_left_s @@ -2423,7 +2417,7 @@ let rec unparse_data return (item :: l, ctxt)) ([], ctxt) (set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items, None), ctxt) + return (Micheline.Seq (-1, items), ctxt) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in fold_left_s @@ -2431,12 +2425,12 @@ let rec unparse_data Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt -> unparse_data ctxt mode kt k >>=? fun (key, ctxt) -> unparse_data ctxt mode vt v >>=? fun (value, ctxt) -> - return (Prim (-1, D_Elt, [ key ; value ], None) :: l, ctxt)) + return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt)) ([], ctxt) (map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) -> - return (Micheline.Seq (-1, items, None), ctxt) + return (Micheline.Seq (-1, items), ctxt) | Big_map_t (_kt, _kv), _map -> - return (Micheline.Seq (-1, [], None), ctxt) + return (Micheline.Seq (-1, []), ctxt) | Lambda_t _, Lam (_, original_code) -> unparse_code ctxt mode (root original_code) @@ -2446,13 +2440,13 @@ and unparse_code ctxt mode = function parse_data ctxt t data >>=? fun (data, ctxt) -> unparse_data ctxt mode t data >>=? fun (data, ctxt) -> return (Prim (loc, I_PUSH, [ ty ; data ], annot), ctxt) - | Seq (loc, items, annot) -> + | Seq (loc, items) -> fold_left_s (fun (l, ctxt) item -> unparse_code ctxt mode item >>=? fun (item, ctxt) -> return (item :: l, ctxt)) ([], ctxt) items >>=? fun (items, ctxt) -> - return (Micheline.Seq (loc, List.rev items, annot), ctxt) + return (Micheline.Seq (loc, List.rev items), ctxt) | Prim (loc, prim, items, annot) -> fold_left_s (fun (l, ctxt) item -> @@ -2466,13 +2460,13 @@ let unparse_script ctxt mode { code ; arg_type ; storage ; storage_type } = let Lam (_, original_code) = code in unparse_code ctxt mode (root original_code) >>=? fun (code, ctxt) -> unparse_data ctxt mode storage_type storage >>=? fun (storage, ctxt) -> - let arg_type = unparse_ty None arg_type in - let storage_type = unparse_ty None storage_type in + let arg_type = unparse_ty [] arg_type in + let storage_type = unparse_ty [] storage_type in let open Micheline in let code = - Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], None) ; - Prim (-1, K_storage, [ storage_type ], None) ; - Prim (-1, K_code, [ code ], None) ], None) in + Seq (-1, [ Prim (-1, K_parameter, [ arg_type ], []) ; + Prim (-1, K_storage, [ storage_type ], []) ; + Prim (-1, K_code, [ code ], []) ]) in return ({ code = lazy_expr (strip_locations code) ; storage = lazy_expr (strip_locations storage) }, ctxt) diff --git a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli index 628686241..2b0e4fc6d 100644 --- a/src/proto_alpha/lib_protocol/src/script_ir_translator.mli +++ b/src/proto_alpha/lib_protocol/src/script_ir_translator.mli @@ -71,7 +71,7 @@ val parse_ty : Script.node -> (ex_ty * Script_typed_ir.annot) tzresult val unparse_ty : - string option -> 'a Script_typed_ir.ty -> Script.node + string list -> 'a Script_typed_ir.ty -> Script.node val parse_toplevel : Script.expr -> (Script.node * Script.node * Script.node) tzresult diff --git a/src/proto_alpha/lib_protocol/src/script_repr.ml b/src/proto_alpha/lib_protocol/src/script_repr.ml index ed4c04308..c070fd9fd 100644 --- a/src/proto_alpha/lib_protocol/src/script_repr.ml +++ b/src/proto_alpha/lib_protocol/src/script_repr.ml @@ -76,17 +76,17 @@ let rec node_size node = let (nblocks, nwords) = node_size node in (blocks + 1 + nblocks, words + 2 + nwords)) (match annot with - | None -> (1, 2) - | Some annot -> (1, 4 + (String.length annot + 7) / 8)) + | [] -> (1, 2) + | annots -> + let annots_length = List.fold_left (fun acc s -> acc + String.length s) 0 annots in + (1, 4 + (annots_length + 7) / 8)) args - | Seq (_, args, annot) -> + | Seq (_, args) -> List.fold_left (fun (blocks, words) node -> let (nblocks, nwords) = node_size node in (blocks + 1 + nblocks, words + 2 + nwords)) - (match annot with - | None -> (1, 2) - | Some annot -> (1, 3 + (String.length annot + 7) / 8)) + (1, 2) args let expr_size expr = diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml index d4c61836b..b1cde98a0 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors.ml @@ -39,7 +39,7 @@ type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> type error += Self_in_lambda of Script.location type error += Bad_stack_length type error += Bad_stack_item of int -type error += Inconsistent_annotations of string * string +type error += Inconsistent_annotations of string list * string list type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error type error += Unexpected_annotation of Script.location type error += Invalid_map_body : Script.location * _ stack_ty -> error diff --git a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml index 24068706d..e2fe5cccd 100644 --- a/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml +++ b/src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml @@ -28,7 +28,7 @@ let type_map_enc = let ex_ty_enc = Data_encoding.conv - (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) + (fun (Ex_ty ty) -> strip_locations (unparse_ty [] ty)) (fun expr -> match parse_ty ~allow_big_map:true ~allow_operation:true (root expr) with | Ok (Ex_ty ty, _) -> Ex_ty ty @@ -73,7 +73,7 @@ let () = let Ex_stack_ty rest = fold rest in Ex_stack_ty (Item_t (ty, rest, annot)) | [] -> Ex_stack_ty Empty_t in - conv unfold fold (list (tup2 ex_ty_enc (option string))) in + conv unfold fold (list (tup2 ex_ty_enc (list string))) in (* -- Structure errors ---------------------- *) (* Invalid arity *) register_error_kind @@ -327,8 +327,8 @@ let () = ~title:"Annotations inconsistent between branches" ~description:"The annotations on two types could not be merged" (obj2 - (req "annot1" string) - (req "annot2" string)) + (req "annot1" (list string)) + (req "annot2" (list string))) (function Inconsistent_annotations (annot1, annot2) -> Some (annot1, annot2) | _ -> None) (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ; diff --git a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml index 79652a120..c1ea2cdab 100644 --- a/src/proto_alpha/lib_protocol/src/script_typed_ir.ml +++ b/src/proto_alpha/lib_protocol/src/script_typed_ir.ml @@ -42,7 +42,7 @@ end type ('key, 'value) map = (module Boxed_map with type key = 'key and type value = 'value) -type annot = string option +type annot = string list type ('arg, 'storage) script = { code : (('arg, 'storage) pair, (packed_internal_operation list, 'storage) pair) lambda ;