Michelson: Force annotations of the same kind to be grouped

docs/whitedoc/michelson.rst

@@ -2158,7 +2158,8 @@ name and before its potential arguments for primitive applications.
 
 
 Ordering between different kinds of annotations is not significant, but
-ordering among annotations of the same kind is.
+ordering among annotations of the same kind is. Annotations of a same
+kind must be grouped together.
 
 For instance these two annotated instructions are equivalent:
 
@@ -2166,7 +2167,7 @@ For instance these two annotated instructions are equivalent:
 
    PAIR :t @my_pair %x %y
 
-   PAIR %x :t %y @my_pair
+   PAIR %x %y :t @my_pair
 
 Annotations and Macros
 ~~~~~~~~~~~~~~~~~~~~~~

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml

@@ -72,6 +72,7 @@ let collect_error_locations errs =
         (Invalid_arity (loc, _, _, _)
         | Inconsistent_type_annotations (loc, _, _)
         | Unexpected_annotation loc
+        | Ungrouped_annotations loc
         | Type_too_large (loc, _, _)
         | Invalid_namespace (loc, _, _, _)
         | Invalid_primitive (loc, _, _)
@@ -388,6 +389,10 @@ let report_errors ~details ~show_source ?parsed ppf errs =
               Format.fprintf ppf
                 "@[<v 2>%aunexpected annotation."
                 print_loc loc
+          | Ungrouped_annotations loc ->
+              Format.fprintf ppf
+                "@[<v 2>%aAnnotations of the same kind must be grouped."
+                print_loc loc
           | Type_too_large (loc, size, maximum_size) ->
               Format.fprintf ppf
                 "@[<v 2>%atype size (%d) exceeded maximum type size (%d)."

src/proto_alpha/lib_protocol/src/script_ir_annot.ml

@@ -214,14 +214,33 @@ let parse_field_annot loc annot =
   Lwt.return (parse_field_annot loc annot)
 
 let classify_annot
-  : annot list -> var_annot list * type_annot list * field_annot list
+  : int -> annot list ->
-  = fun l ->
+    (var_annot list * type_annot list * field_annot list) tzresult Lwt.t
-    let rv, rt, rf = List.fold_left (fun (rv, rt, rf) -> function
+  = fun loc l ->
-        | `Var_annot _ as a -> a :: rv, rt, rf
+    try
-        | `Type_annot _ as a -> rv, a :: rt, rf
+      let _, rv, _, rt, _, rf =
-        | `Field_annot _ as a -> rv, rt, a :: rf
+        List.fold_left
-      ) ([], [], []) l in
+          (fun (in_v, rv, in_t, rt, in_f, rf) a ->
-    List.rev rv, List.rev rt, List.rev rf
+             match a, in_v, rv, in_t, rt, in_f, rf with
+             | (`Var_annot _ as a), true, _, _, _, _, _
+             | (`Var_annot _ as a), false, [], _, _, _, _ ->
+                 true, a :: rv,
+                 false, rt,
+                 false, rf
+             | (`Type_annot _ as a), _, _, true, _, _, _
+             | (`Type_annot _ as a), _, _, false, [], _, _ ->
+                 false, rv,
+                 true, a :: rt,
+                 false, rf
+             | (`Field_annot _ as a), _, _, _, _, true, _
+             | (`Field_annot _ as a), _, _, _, _, false, [] ->
+                 false, rv,
+                 false, rt,
+                 true, a :: rf
+             | _ -> raise Exit
+          ) (false, [], false, [], false, []) l in
+      Lwt.return (ok (List.rev rv, List.rev rt, List.rev rf))
+    with Exit -> Lwt.return (error (Ungrouped_annotations loc))
 
 let get_one_annot loc = function
   | [] -> Lwt.return (ok None)
@@ -239,7 +258,7 @@ let parse_constr_annot
     (var_annot option * type_annot option * field_annot option * field_annot option) tzresult Lwt.t
   = fun loc annot ->
     Lwt.return (parse_annots loc annot) >>=? fun annot ->
-    let vars, types, fields = classify_annot annot in
+    classify_annot loc annot >>=? fun (vars, types, fields) ->
     get_one_annot loc vars >>=? fun v ->
     get_one_annot loc types >>=? fun t ->
     get_two_annot loc fields >>|? fun (f1, f2) ->
@@ -249,7 +268,7 @@ let parse_two_var_annot
   : int -> string list -> (var_annot option * var_annot option) tzresult Lwt.t
   = fun loc annot ->
     Lwt.return (parse_annots loc annot) >>=? fun annot ->
-    let vars, types, fields = classify_annot annot in
+    classify_annot loc annot >>=? fun (vars, types, fields) ->
     fail_unexpected_annot loc types >>=? fun () ->
     fail_unexpected_annot loc fields >>=? fun () ->
     get_two_annot loc vars
@@ -258,7 +277,7 @@ let parse_var_field_annot
   : int -> string list -> (var_annot option * field_annot option) tzresult Lwt.t
   = fun loc annot ->
     Lwt.return (parse_annots loc annot) >>=? fun annot ->
-    let vars, types, fields = classify_annot annot in
+    classify_annot loc annot >>=? fun (vars, types, fields) ->
     fail_unexpected_annot loc types >>=? fun () ->
     get_one_annot loc vars >>=? fun v ->
     get_one_annot loc fields >>|? fun f ->
@@ -268,7 +287,7 @@ let parse_var_type_annot
   : int -> string list -> (var_annot option * type_annot option) tzresult Lwt.t
   = fun loc annot ->
     Lwt.return (parse_annots loc annot) >>=? fun annot ->
-    let vars, types, fields = classify_annot annot in
+    classify_annot loc annot >>=? fun (vars, types, fields) ->
     fail_unexpected_annot loc fields >>=? fun () ->
     get_one_annot loc vars >>=? fun v ->
     get_one_annot loc types >>|? fun t ->

src/proto_alpha/lib_protocol/src/script_tc_errors.ml

@@ -43,6 +43,7 @@ type error += Inconsistent_annotations of string * string
 type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
 type error += Inconsistent_field_annotations of string * string
 type error += Unexpected_annotation of Script.location
+type error += Ungrouped_annotations of Script.location
 type error += Invalid_map_body : Script.location * _ stack_ty -> error
 type error += Invalid_map_block_fail of Script.location
 type error += Invalid_iter_body : Script.location * _ stack_ty * _ stack_ty -> error

src/proto_alpha/lib_protocol/src/script_tc_errors_registration.ml

@@ -370,6 +370,16 @@ let () =
     (function Unexpected_annotation loc -> Some (loc, ())
             | _ -> None)
     (fun (loc, ()) -> Unexpected_annotation loc);
+  (* Unexpected annotation *)
+  register_error_kind
+    `Permanent
+    ~id:"ungroupedAnnotations"
+    ~title:"Annotations of the same kind were found spread apart"
+    ~description:"Annotations of the same kind must be grouped"
+    (located empty)
+    (function Ungrouped_annotations loc -> Some (loc, ())
+            | _ -> None)
+    (fun (loc, ()) -> Ungrouped_annotations loc);
   (* Unmatched branches *)
   register_error_kind
     `Permanent