From 9993553a594fa699e9fca682a8cf01565914a14c Mon Sep 17 00:00:00 2001
From: Alain Mebsout <alainmebsout@gmail.com>
Date: Tue, 29 May 2018 17:01:43 +0200
Subject: [PATCH] Michelson: Propagate annotations in execution trace

Fixes #179
---
 src/proto_alpha/lib_client/client_proto_programs.ml |  8 +++++++-
 .../lib_protocol/src/helpers_services.ml            |  8 ++++++--
 .../lib_protocol/src/script_interpreter.ml          | 13 +++++++++----
 .../lib_protocol/src/script_interpreter.mli         |  2 +-
 4 files changed, 23 insertions(+), 8 deletions(-)

diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml
index ae80d99d1..399a1a70b 100644
--- a/src/proto_alpha/lib_client/client_proto_programs.ml
+++ b/src/proto_alpha/lib_client/client_proto_programs.ml
@@ -79,7 +79,13 @@ let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
                 "- @[<v 0>location: %d (remaining gas: %a)@,\
                  [ @[<v 0>%a ]@]@]"
                 loc Gas.pp gas
-                (Format.pp_print_list print_expr)
+                (Format.pp_print_list
+                   (fun ppf (e, annot) ->
+                      Format.fprintf ppf
+                        "@[<v 0>%a  \t%s@]"
+                        print_expr e
+                        (match annot with None -> "" | Some a -> a)
+                   ))
                 stack))
         trace >>= fun () ->
       return ()
diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml
index 37018eb11..e3571dba7 100644
--- a/src/proto_alpha/lib_protocol/src/helpers_services.ml
+++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml
@@ -76,7 +76,11 @@ module Scripts = struct
                        (list @@ obj3
                           (req "location" Script.location_encoding)
                           (req "gas" Gas.encoding)
-                          (req "stack" (list (Script.expr_encoding)))))
+                          (req "stack"
+                             (list
+                                (obj2
+                                   (req "item" (Script.expr_encoding))
+                                   (opt "annot" string))))))
                     (opt "big_map_diff" (list (tup2 string (option Script.expr_encoding)))))
         RPC_path.(path / "trace_code")
 
@@ -172,7 +176,7 @@ module Scripts = struct
       begin match maybe_gas with
         | None -> return (Gas.set_unlimited ctxt)
         | Some gas -> Lwt.return (Gas.set_limit ctxt gas) end >>=? fun ctxt ->
-      Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ, _) ->
+      Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false (Micheline.root typ)) >>=? fun (Ex_ty typ) ->
       parse_data ctxt typ (Micheline.root expr) >>=? fun (data, ctxt) ->
       Script_ir_translator.hash_data ctxt typ data >>=? fun (hash, ctxt) ->
       return (hash, Gas.level ctxt)
diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.ml b/src/proto_alpha/lib_protocol/src/script_interpreter.ml
index ce9d99978..ef2309e60 100644
--- a/src/proto_alpha/lib_protocol/src/script_interpreter.ml
+++ b/src/proto_alpha/lib_protocol/src/script_interpreter.ml
@@ -77,19 +77,24 @@ let unparse_stack ctxt (stack, stack_ty) =
   (* We drop the gas limit as this function is only used for debugging/errors. *)
   let ctxt = Gas.set_unlimited ctxt in
   let rec unparse_stack
-    : type a. a stack * a stack_ty -> Script.expr list tzresult Lwt.t
+    : type a. a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
     = function
       | Empty, Empty_t -> return []
-      | Item (v, rest), Item_t (ty, rest_ty, _) ->
+      | Item (v, rest), Item_t (ty, rest_ty, annot) ->
           unparse_data ctxt Readable ty v >>=? fun (data, _ctxt) ->
           unparse_stack (rest, rest_ty) >>=? fun rest ->
-          return (Micheline.strip_locations data :: rest) in
+          let annot = match Script_ir_annot.unparse_var_annot annot with
+            | [] -> None
+            | [ a ] -> Some a
+            | _ -> assert false in
+          let data = Micheline.strip_locations data in
+          return ((data, annot) :: rest) in
   unparse_stack (stack, stack_ty)
 
 module Interp_costs = Michelson_v1_gas.Cost_of
 
 type execution_trace =
-  (Script.location * Gas.t * Script.expr list) list
+  (Script.location * Gas.t * (Script.expr * string option) list) list
 
 let rec interp
   : type p r.
diff --git a/src/proto_alpha/lib_protocol/src/script_interpreter.mli b/src/proto_alpha/lib_protocol/src/script_interpreter.mli
index 76c437ad3..3aa5fdbb0 100644
--- a/src/proto_alpha/lib_protocol/src/script_interpreter.mli
+++ b/src/proto_alpha/lib_protocol/src/script_interpreter.mli
@@ -31,7 +31,7 @@ val execute:
   execution_result tzresult Lwt.t
 
 type execution_trace =
-  (Script.location * Gas.t * Script.expr list) list
+  (Script.location * Gas.t * (Script.expr * string option) list) list
 
 val trace:
   Alpha_context.t ->