Merge branch 'feature/auto-field-annotations' into 'dev'

Generate field annotations for sum/record

See merge request ligolang/ligo!78

src/main/compile/of_mini_c.ml

@@ -48,7 +48,8 @@ let compile_contract_entry = fun program name ->
   in
   let%bind param_michelson = Compiler.Type.type_ param_ty in
   let%bind storage_michelson = Compiler.Type.type_ storage_ty in
-  let contract = Michelson.contract param_michelson storage_michelson compiled.body in
+  let body = Michelson.strip_annots compiled.body in
+  let contract = Michelson.contract param_michelson storage_michelson body in
   ok contract
 
 

src/main/run/of_michelson.ml

@@ -24,7 +24,7 @@ let run ?options (* ?(is_input_value = false) *) (program:compiled_program) (inp
     Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
     Memory_proto_alpha.parse_michelson_data input_michelson input_ty
   in
-  let body = Michelson.(strip_nops @@ strip_annots body) in
+  let body = Michelson.strip_annots body in
   let%bind descr =
     Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
     Memory_proto_alpha.parse_michelson body

src/passes/6-transpiler/transpiler.ml

@@ -56,7 +56,7 @@ them. please report this to the developers." in
 
   let bad_big_map location =
     let title () = "bad arguments for main" in
-    let content () = "only one big_map per program which must appear 
+    let content () = "only one big_map per program which must appear
       on the left hand side of a pair in the contract's storage" in
     let data = [
       ("location" , fun () -> Format.asprintf "%a" Location.pp location) ;
@@ -131,28 +131,39 @@ let rec transpile_type (t:AST.type_value) : type_value result =
       let%bind o' = transpile_type o in
       ok (T_option o')
   | T_constant (name , _lst) -> fail @@ unrecognized_type_constant name
+  (* TODO hmm *)
   | T_sum m ->
-      let node = Append_tree.of_list @@ list_of_map m in
+      let node = Append_tree.of_list @@ kv_list_of_map m in
-      let aux a b : type_value result =
+      let aux a b : type_value annotated result =
         let%bind a = a in
         let%bind b = b in
-        ok (T_or (a, b))
+        ok (None, T_or (a, b))
       in
-      Append_tree.fold_ne transpile_type aux node
+      let%bind m' = Append_tree.fold_ne
+                      (fun (ann, a) ->
+                        let%bind a = transpile_type a in
+                        ok (Some (String.uncapitalize_ascii ann), a))
+                      aux node in
+      ok @@ snd m'
   | T_record m ->
-      let node = Append_tree.of_list @@ list_of_map m in
+      let node = Append_tree.of_list @@ kv_list_of_map m in
-      let aux a b : type_value result =
+      let aux a b : type_value annotated result =
         let%bind a = a in
         let%bind b = b in
-        ok (T_pair (a, b))
+        ok (None, T_pair (a, b))
       in
-      Append_tree.fold_ne transpile_type aux node
+      let%bind m' = Append_tree.fold_ne
+                      (fun (ann, a) ->
+                        let%bind a = transpile_type a in
+                        ok (Some ann, a))
+                      aux node in
+      ok @@ snd m'
   | T_tuple lst ->
       let node = Append_tree.of_list lst in
       let aux a b : type_value result =
         let%bind a = a in
         let%bind b = b in
-        ok (T_pair (a, b))
+        ok (T_pair ((None, a), (None, b)))
       in
       Append_tree.fold_ne transpile_type aux node
   | T_function (param, result) -> (
@@ -285,10 +296,10 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         let%bind a = a in
         let%bind b = b in
         match (a, b) with
-        | (None, a), (None, b) -> ok (None, T_or (a, b))
+        | (None, a), (None, b) -> ok (None, T_or ((None, a), (None, b)))
         | (Some _, _), (Some _, _) -> fail @@ corner_case ~loc:__LOC__ "multiple identical constructors in the same variant"
-        | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or (a, b))
+        | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a)])), T_or ((None, a), (None, b)))
-        | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or (a, b))
+        | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b)])), T_or ((None, a), (None, b)))
       in
       let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in
       let%bind ae =
@@ -303,7 +314,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         let%bind b = b in
         let a_ty = Combinators.Expression.get_type a in
         let b_ty = Combinators.Expression.get_type b in
-        let tv = T_pair (a_ty , b_ty) in
+        let tv = T_pair ((None, a_ty) , (None, b_ty)) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
       Append_tree.fold_ne (transpile_annotated_expression) aux node
@@ -333,7 +344,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
         let%bind b = b in
         let a_ty = Combinators.Expression.get_type a in
         let b_ty = Combinators.Expression.get_type b in
-        let tv = T_pair (a_ty , b_ty) in
+        let tv = T_pair ((None, a_ty) , (None, b_ty)) in
         return ~tv @@ E_constant ("PAIR", [a; b])
       in
       trace_strong (corner_case ~loc:__LOC__ "record build") @@
@@ -551,7 +562,7 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
               | Node {a ; b} ->
                   let%bind a' = aux a in
                   let%bind b' = aux b in
-                  let tv' = Mini_c.t_union (snd a') (snd b') in
+                  let tv' = Mini_c.t_union (None, snd a') (None, snd b') in
                   ok (`Node (a' , b') , tv')
             in aux tree'
           in
@@ -644,8 +655,8 @@ let check_storage f ty loc : (anon_function * _) result =
   let rec aux (t:type_value) on_big_map =
     match t with
       | T_big_map _ -> on_big_map
-      | T_pair (a , b) -> (aux a true) && (aux b false)
+      | T_pair (a , b) -> (aux (snd a) true) && (aux (snd b) false)
-      | T_or (a,b) -> (aux a false) && (aux b false)
+      | T_or (a,b) -> (aux (snd a) false) && (aux (snd b) false)
       | T_function (a,b) -> (aux a false) && (aux b false)
       | T_deep_closure (_,a,b) -> (aux a false) && (aux b false)
       | T_map (a,b) -> (aux a false) && (aux b false)
@@ -657,7 +668,7 @@ let check_storage f ty loc : (anon_function * _) result =
   in
   match f.body.type_value with
     | T_pair (_, storage) ->
-      if aux storage false then ok (f, ty) else fail @@ bad_big_map loc
+      if aux (snd storage) false then ok (f, ty) else fail @@ bad_big_map loc
     | _ -> ok (f, ty)
 
 let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value * AST.type_value) result =

src/passes/8-compiler/compiler_type.ml

@@ -43,6 +43,13 @@ module Ty = struct
   let pair a b = Pair_t ((a, None, None), (b, None, None), None)
   let union a b = Union_t ((a, None), (b, None), None)
 
+  let field_annot = Option.map (fun ann -> `Field_annot ann)
+
+  let union_ann (anna, a) (annb, b) =
+    Union_t ((a, field_annot anna), (b, field_annot annb), None)
+
+  let pair_ann (anna, a) (annb, b) =
+    Pair_t ((a, field_annot anna, None), (b, field_annot annb, None), None)
 
   let not_comparable name () = error (thunk "not a comparable type") (fun () -> name) ()
   let not_compilable_type name () = error (thunk "not a compilable type") (fun () -> name) ()
@@ -95,14 +102,14 @@ module Ty = struct
     function
     | T_base b -> base_type b
     | T_pair (t, t') -> (
-        type_ t >>? fun (Ex_ty t) ->
+        annotated t >>? fun (ann, Ex_ty t) ->
-        type_ t' >>? fun (Ex_ty t') ->
+        annotated t' >>? fun (ann', Ex_ty t') ->
-        ok @@ Ex_ty (pair t t')
+        ok @@ Ex_ty (pair_ann (ann, t) (ann', t'))
       )
     | T_or (t, t') -> (
-        type_ t >>? fun (Ex_ty t) ->
+        annotated t >>? fun (ann, Ex_ty t) ->
-        type_ t' >>? fun (Ex_ty t') ->
+        annotated t' >>? fun (ann', Ex_ty t') ->
-        ok @@ Ex_ty (union t t')
+        ok @@ Ex_ty (union_ann (ann, t) (ann', t'))
       )
     | T_function (arg, ret) ->
         let%bind (Ex_ty arg) = type_ arg in
@@ -135,6 +142,10 @@ module Ty = struct
         let%bind (Ex_ty t') = type_ t in
         ok @@ Ex_ty (contract t')
 
+  and annotated : type_value annotated -> ex_ty annotated result =
+    fun (ann, a) -> let%bind a = type_ a in
+                    ok @@ (ann, a)
+
   and environment_representation = fun e ->
     match List.rev_uncons_opt e with
     | None -> ok @@ Ex_ty unit
@@ -177,13 +188,13 @@ let rec type_ : type_value -> O.michelson result =
   function
   | T_base b -> base_type b
   | T_pair (t, t') -> (
-      type_ t >>? fun t ->
+      annotated t >>? fun t ->
-      type_ t' >>? fun t' ->
+      annotated t' >>? fun t' ->
       ok @@ O.prim ~children:[t;t'] O.T_pair
     )
   | T_or (t, t') -> (
-      type_ t >>? fun t ->
+      annotated t >>? fun t ->
-      type_ t' >>? fun t' ->
+      annotated t' >>? fun t' ->
       ok @@ O.prim ~children:[t;t'] O.T_or
     )
   | T_map kv ->
@@ -213,6 +224,13 @@ let rec type_ : type_value -> O.michelson result =
       let%bind lambda = lambda_closure (c , arg , ret) in
       ok @@ O.t_pair lambda capture
 
+and annotated : type_value annotated -> O.michelson result =
+  function
+  | (Some ann, o) ->
+     let%bind o' = type_ o in
+     ok (O.annotate ("%" ^ ann) o')
+  | (None, o) -> type_ o
+
 and environment_element (name, tyv) =
   let%bind michelson_type = type_ tyv in
   ok @@ O.annotate ("@" ^ name) michelson_type

src/stages/mini_c/PP.ml

@@ -22,8 +22,8 @@ let type_base ppf : type_base -> _ = function
   | Base_operation -> fprintf ppf "operation"
 
 let rec type_ ppf : type_value -> _ = function
-  | T_or(a, b) -> fprintf ppf "(%a) | (%a)" type_ a type_ b
+  | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b
-  | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" type_ a type_ b
+  | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b
   | T_base b -> type_base ppf b
   | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b
   | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
@@ -37,6 +37,10 @@ let rec type_ ppf : type_value -> _ = function
         environment c
         type_ arg type_ ret
 
+and annotated ppf : type_value annotated -> _ = function
+  | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_ a ann
+  | (None, a) -> type_ ppf a
+
 and environment_element ppf ((s, tv) : environment_element) =
   Format.fprintf ppf "%s : %a" s type_ tv
 

src/stages/mini_c/combinators.ml

@@ -102,11 +102,11 @@ let get_pair (v:value) = match v with
   | _ -> simple_fail "not a pair"
 
 let get_t_pair (t:type_value) = match t with
-  | T_pair (a, b) -> ok (a, b)
+  | T_pair ((_, a), (_, b)) -> ok (a, b)
   | _ -> simple_fail "not a type pair"
 
 let get_t_or (t:type_value) = match t with
-  | T_or (a, b) -> ok (a, b)
+  | T_or ((_, a), (_, b)) -> ok (a, b)
   | _ -> simple_fail "not a type or"
 
 let get_t_map (t:type_value) = match t with
@@ -144,11 +144,11 @@ let wrong_type name t =
   error title content
 
 let get_t_left t = match t with
-  | T_or (a , _) -> ok a
+  | T_or ((_, a) , _) -> ok a
   | _ -> fail @@ wrong_type "union" t
 
 let get_t_right t = match t with
-  | T_or (_ , b) -> ok b
+  | T_or (_ , (_, b)) -> ok b
   | _ -> fail @@ wrong_type "union" t
 
 let get_t_contract t = match t with

src/stages/mini_c/types.ml

@@ -8,9 +8,11 @@ type type_base =
   | Base_string | Base_bytes | Base_address
   | Base_operation
 
+type 'a annotated = string option * 'a
+
 type type_value =
-  | T_pair of (type_value * type_value)
+  | T_pair of (type_value annotated * type_value annotated)
-  | T_or of type_value * type_value
+  | T_or of (type_value annotated * type_value annotated)
   | T_function of (type_value * type_value)
   | T_deep_closure of (environment * type_value * type_value)
   | T_base of type_base

vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml

@@ -953,8 +953,6 @@ let parse_michelson (type aft)
     ?type_logger
     (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty)
   =
-  let michelson = Michelson.strip_annots michelson in
-  let michelson = Michelson.strip_nops michelson in
   parse_instr
     ?type_logger
     top_level tezos_context
@@ -975,8 +973,6 @@ let parse_michelson_fail (type aft)
     ?type_logger
     (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty)
   =
-  let michelson = Michelson.strip_annots michelson in
-  let michelson = Michelson.strip_nops michelson in
   parse_instr
     ?type_logger
     top_level tezos_context
@@ -995,8 +991,6 @@ let parse_michelson_fail (type aft)
 let parse_michelson_data
     ?(tezos_context = dummy_environment.tezos_context)
     michelson ty =
-  let michelson = Michelson.strip_annots michelson in
-  let michelson = Michelson.strip_nops michelson in
   parse_data tezos_context ty michelson >>=?? fun (data, _) ->
   return data
 
@@ -1004,8 +998,6 @@ let parse_michelson_ty
     ?(tezos_context = dummy_environment.tezos_context)
     ?(allow_big_map = true) ?(allow_operation = true)
     michelson =
-  let michelson = Michelson.strip_annots michelson in
-  let michelson = Michelson.strip_nops michelson in
   Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) ->
   return ty
 

vendors/ligo-utils/tezos-utils/x_michelson.ml

@@ -75,12 +75,6 @@ let rec strip_annots : michelson -> michelson = function
   | Prim (l, p, lst, _) -> Prim (l, p, List.map strip_annots lst, [])
   | x -> x
 
-let rec strip_nops : michelson -> michelson = function
-  | Seq(l, [Prim (_, I_UNIT, _, _) ; Prim(_, I_DROP, _, _)]) -> Seq (l, [])
-  | Seq(l, s) -> Seq(l, List.map strip_nops s)
-  | Prim (l, p, lst, a) -> Prim (l, p, List.map strip_nops lst, a)
-  | x -> x
-
 let pp ppf (michelson:michelson) =
   let open Micheline_printer in
   let canonical = strip_locations michelson in
@@ -98,15 +92,3 @@ let pp_json ppf (michelson : michelson) =
     )
   in
   Format.fprintf ppf "%a" Tezos_data_encoding.Json.pp json
-
-let pp_stripped ppf (michelson:michelson) =
-  let open Micheline_printer in
-  let michelson' = strip_nops @@ strip_annots michelson in
-  let canonical = strip_locations michelson' in
-  let node = printable string_of_prim canonical in
-  print_expr ppf node
-
-let pp_naked ppf m =
-  let naked = strip_annots m in
-  pp ppf naked
-