From ff284cc0c02cbf3feb46943ab20bbdc107171069 Mon Sep 17 00:00:00 2001 From: Alain Mebsout Date: Fri, 25 May 2018 11:50:52 +0200 Subject: [PATCH] Michelson: field annotations on PAIR macros --- src/bin_client/test/contracts/pair_macro.tz | 6 +- src/bin_client/test/contracts/unpair_macro.tz | 6 +- .../lib_client/michelson_v1_macros.ml | 60 +++++++++++++------ 3 files changed, 48 insertions(+), 24 deletions(-) diff --git a/src/bin_client/test/contracts/pair_macro.tz b/src/bin_client/test/contracts/pair_macro.tz index 430f0320b..614f8680b 100644 --- a/src/bin_client/test/contracts/pair_macro.tz +++ b/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; - CDR; NIL operation; PAIR} +code { UNIT; UNIT; UNIT; UNIT; UNIT; + PAPAPAPAIR @name %1 %2 %3 %4 %5; + CDDDAR %4 @fourth; + DROP; CDR; NIL operation; PAIR} diff --git a/src/bin_client/test/contracts/unpair_macro.tz b/src/bin_client/test/contracts/unpair_macro.tz index edd5f9308..868118536 100644 --- a/src/bin_client/test/contracts/unpair_macro.tz +++ b/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; - PAPAPAIR; UNPAPAPAIR @un @deux @trois @quatre; - PAPPAIIR; UNPAPPAIIR @one @two @three @four; + PPAIPAIR @p1 %x1 %x2 %x3 %x4; UNPPAIPAIR @uno @due @tre @quattro; + PAPAPAIR @p2 %x1 %x2 %x3 %x4; UNPAPAPAIR @un @deux @trois @quatre; + PAPPAIIR @p3 %x1 %x2 %x3 %x4; UNPAPPAIIR @one @two @three @four; DROP; DROP; DROP; DROP; CAR; NIL operation; PAIR } \ No newline at end of file diff --git a/src/proto_alpha/lib_client/michelson_v1_macros.ml b/src/proto_alpha/lib_client/michelson_v1_macros.ml index 6332fcc26..339462f9a 100644 --- a/src/proto_alpha/lib_client/michelson_v1_macros.ml +++ b/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) ->