Michelson: field annotations on PAIR macros

src/bin_client/test/contracts/pair_macro.tz

@@ -1,4 +1,6 @@
 parameter unit;
 storage unit;
-code { UNIT; UNIT; UNIT; UNIT; UNIT; PAPAPAPAIR @name; DROP;
+code { UNIT; UNIT; UNIT; UNIT; UNIT;
-       CDR; NIL operation; PAIR}
+       PAPAPAPAIR @name %1 %2 %3 %4 %5;
+       CDDDAR %4 @fourth;
+       DROP; CDR; NIL operation; PAIR}

src/bin_client/test/contracts/unpair_macro.tz

@@ -2,7 +2,7 @@ parameter unit;
 storage unit;
 code { UNIT @4; UNIT @3; UNIT @2; UNIT @1;
        PAIR; UNPAIR @x1 @x2;
-       PPAIPAIR; UNPPAIPAIR @uno @due @tres @quatro;
+       PPAIPAIR @p1 %x1 %x2 %x3 %x4; UNPPAIPAIR @uno @due @tre @quattro;
-       PAPAPAIR; UNPAPAPAIR @un @deux @trois @quatre;
+       PAPAPAIR @p2 %x1 %x2 %x3 %x4; UNPAPAPAIR @un @deux @trois @quatre;
-       PAPPAIIR; UNPAPPAIIR @one @two @three @four;
+       PAPPAIIR @p3 %x1 %x2 %x3 %x4; UNPAPPAIIR @one @two @three @four;
        DROP; DROP; DROP; DROP; CAR; NIL operation; PAIR }

src/proto_alpha/lib_client/michelson_v1_macros.ml

@@ -59,6 +59,14 @@ let extract_first_field_annot annot =
   in
   extract_first_field_annot [] annot
 
+let extract_field_annots annot =
+  List.partition (fun a ->
+      match a.[0] with
+      | '%' -> true
+      | _ -> false
+      | exception Invalid_argument _ -> false
+    ) annot
+
 let expand_set_caddadr original =
   match original with
   | Prim (loc, str, args, annot) ->
@@ -316,6 +324,25 @@ let unparse_pair_item ast =
     | I -> "I" :: acc in
   List.rev ("R" :: unparse ast []) |> String.concat ""
 
+let pappaiir_annots_pos ast annot =
+  let rec find_annots_pos p_pos ast annots acc =
+    match ast, annots with
+    | _, [] -> annots, acc
+    | P (i, left, right), _ ->
+        let annots, acc = find_annots_pos i left annots acc in
+        find_annots_pos i right annots acc
+    | A, a :: annots ->
+        let pos = match IntMap.find_opt p_pos acc with
+          | None -> [ a ], []
+          | Some (_, cdr) -> [ a ], cdr in
+        annots, IntMap.add p_pos pos acc
+    | I, a :: annots ->
+        let pos = match IntMap.find_opt p_pos acc with
+          | None -> [], [ a ]
+          | Some (car, _) -> car, [ a ] in
+        annots, IntMap.add p_pos pos acc in
+  snd (find_annots_pos 0 ast annot IntMap.empty)
+
 let expand_pappaiir original =
   match original with
   | Prim (loc, str, args, annot) ->
@@ -326,17 +353,28 @@ let expand_pappaiir original =
       && check_letters str 1 (len - 2)
            (function 'P' | 'A' | 'I' -> true | _ -> false) then
         try
+          let field_annots, annot = extract_field_annots annot in
+          let ast = parse_pair_substr str ~len 0 in
+          let field_annots_pos = pappaiir_annots_pos ast field_annots in
           let rec parse p (depth, acc) =
             match p with
             | P (i, left, right) ->
-                let annot = if i = 0 then annot else [] in
+                let annot =
+                  match i, IntMap.find_opt i field_annots_pos with
+                  | 0, None -> annot
+                  | _, None -> []
+                  (* XXX Hackish, cannot annotate cdr only with PAIR *)
+                  | 0, Some ([], cdr_annot) -> "%" :: cdr_annot @ annot
+                  | _, Some ([], cdr_annot) -> "%" :: cdr_annot
+                  | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot
+                  | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot
+                in
                 let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in
                 (depth, acc)
                 |> parse left
                 |> parse right
             | A | I -> (depth + 1, acc)
           in
-          let ast = parse_pair_substr str ~len 0 in
           let _, expanded = parse ast (0, []) in
           begin match args with
             | [] -> ok ()
@@ -363,24 +401,8 @@ let expand_unpappaiir original =
                         Prim (loc, "CAR", [], car_annot) ;
                         dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ;
                       ]) in
-          let rec find_annots_pos p_pos ast annots acc =
-            match ast, annots with
-            | _, [] -> annots, acc
-            | P (i, left, right), _ ->
-                let annots, acc = find_annots_pos i left annots acc in
-                find_annots_pos i right annots acc
-            | A, a :: annots ->
-                let pos = match IntMap.find_opt p_pos acc with
-                  | None -> [ a ], []
-                  | Some (_, cdr) -> [ a ], cdr in
-                annots, IntMap.add p_pos pos acc
-            | I, a :: annots ->
-                let pos = match IntMap.find_opt p_pos acc with
-                  | None -> [], [ a ]
-                  | Some (car, _) -> car, [ a ] in
-                annots, IntMap.add p_pos pos acc in
           let ast = parse_pair_substr str ~len 2 in
-          let _, annots_pos = find_annots_pos 0 ast annot IntMap.empty in
+          let annots_pos = pappaiir_annots_pos ast annot in
           let rec parse p (depth, acc) =
             match p with
             | P (i, left, right) ->