Michelson: better propagation and printing of errors to the client

src/client/embedded/alpha/client_proto_context.ml

@@ -380,12 +380,16 @@ let commands () =
       originate_contract cctxt.rpc_config cctxt.config.block ~force:!force
         ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
         ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init
-        () >>=? fun (oph, contract) ->
+        () >>=function
-      message_injection cctxt
+      | Error errs ->
-        ~force:!force ~contracts:[contract] oph >>= fun () ->
+          Client_proto_programs.report_errors cctxt errs >>= fun () ->
-      RawContractAlias.add cctxt neu contract >>=? fun () ->
+          cctxt.error "origination simulation failed"
-      message_added_contract cctxt neu >>= fun () ->
+      | Ok (oph, contract) ->
-      return ()
+          message_injection cctxt
+            ~force:!force ~contracts:[contract] oph >>= fun () ->
+          RawContractAlias.add cctxt neu contract >>=? fun () ->
+          message_added_contract cctxt neu >>= fun () ->
+          return ()
     end ;
 
     command ~group ~desc: "open a new (free) account"
@@ -425,9 +429,13 @@ let commands () =
       get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
       transfer cctxt.rpc_config cctxt.config.block ~force:!force
         ~source ~src_pk ~src_sk ~destination
-        ?arg:!arg ~amount ~fee:!fee () >>=? fun (oph, contracts) ->
+        ?arg:!arg ~amount ~fee:!fee () >>= function
-      message_injection cctxt ~force:!force ~contracts oph >>= fun () ->
+      | Error errs ->
-      return ()
+          Client_proto_programs.report_errors cctxt errs >>= fun () ->
+          cctxt.error "transfer simulation failed"
+      | Ok (oph, contracts) ->
+          message_injection cctxt ~force:!force ~contracts oph >>= fun () ->
+          return ()
     end;
 
     command ~desc: "Activate a protocol" begin

src/client/embedded/alpha/client_proto_programs.ml

@@ -185,6 +185,7 @@ let print_program locations ppf ((c : Script.code), type_map) =
 let collect_error_locations errs =
   let open Script_typed_ir in
   let open Script_ir_translator in
+  let open Script_interpreter in
   let rec collect acc = function
     | (Ill_typed_data (_, _, _)
       | Ill_formed_type (_, _)
@@ -205,15 +206,19 @@ let collect_error_locations errs =
       | Transfer_in_lambda loc
       | Invalid_constant (loc, _, _)
       | Invalid_contract (loc, _)
-      | Comparable_type_expected (loc, _)) :: rest ->
+      | Comparable_type_expected (loc, _)
+      | Overflow loc
+      | Reject loc
+      | Division_by_zero loc) :: rest ->
         collect (loc :: acc) rest
     | _ :: rest -> collect acc rest in
   collect [] errs
 
-let report_typechecking_errors ?show_types cctxt errs =
+let report_errors cctxt errs =
   let open Client_commands in
   let open Script_typed_ir in
   let open Script_ir_translator in
+  let open Script_interpreter in
   let rec print_ty (type t) ppf (ty : t ty) =
     let expr = unparse_ty ty in
     print_expr no_locations ppf expr in
@@ -246,7 +251,7 @@ let report_typechecking_errors ?show_types cctxt errs =
         Format.fprintf ppf "%a,@ %a"
           Format.pp_print_text first print_enumeration rest
     | [] -> assert false in
-  let print_typechecking_error locations err =
+  let print_error locations err =
     let print_loc ppf loc =
       match locations loc with
       | None ->
@@ -273,12 +278,18 @@ let report_typechecking_errors ?show_types cctxt errs =
           name
           (print_expr locations) expr
     | Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty, type_map) ->
-        (match show_types with
-         | Some prog -> cctxt.message "%a\n" (print_program no_locations) (prog, type_map)
-         | None -> Lwt.return ()) >>= fun () ->
         cctxt.warning
           "@[<v 2>Ill typed contract:@ %a@]"
           (print_program locations)
+          ({ Script.storage_type = unparse_ty storage_ty ;
+             arg_type = unparse_ty arg_ty ;
+             ret_type = unparse_ty ret_ty ;
+             code = expr }, type_map)
+    | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) ->
+        cctxt.warning
+          "@[<v 2>Runtime error in contract %a:@ %a@]"
+          Contract.pp contract
+          (print_program locations)
           ({ Script.storage_type = unparse_ty storage_ty ;
              arg_type = unparse_ty arg_ty ;
              ret_type = unparse_ty ret_ty ;
@@ -416,14 +427,18 @@ let report_typechecking_errors ?show_types cctxt errs =
           "@[<hov 0>@[<hov 2>Type@ %a@]@ \
            @[<hov 2>is not compatible with type@ %a.@]@]"
           print_ty tya print_ty tyb
+    | Reject _ -> cctxt.warning "Script reached FAIL instruction"
+    | Overflow _ -> cctxt.warning "Unexpected arithmetic overflow"
+    | Division_by_zero _ -> cctxt.warning "Division by zero"
     | err ->
         cctxt.warning "%a"
           Local_environment.Environment.Error_monad.pp_print_error [ err ] in
-  let rec print_typechecking_error_trace locations errs =
+  let rec print_error_trace locations errs =
     let locations = match errs with
       | (Ill_typed_data (_, _, _)
         | Ill_formed_type (_, _)
-        | Ill_typed_contract (_, _, _, _, _)) :: rest ->
+        | Ill_typed_contract (_, _, _, _, _)
+        | Runtime_contract_error (_, _, _, _, _)) :: rest ->
           let collected =
             collect_error_locations rest in
           let assoc, _ =
@@ -439,12 +454,12 @@ let report_typechecking_errors ?show_types cctxt errs =
     match errs with
     | [] -> Lwt.return ()
     | err :: errs ->
-        print_typechecking_error locations err >>= fun () ->
+        print_error locations err >>= fun () ->
-        print_typechecking_error_trace locations errs in
+        print_error_trace locations errs in
   Lwt_list.iter_s
     (function
       | Ecoproto_error errs ->
-          print_typechecking_error_trace no_locations errs
+          print_error_trace no_locations errs
       | err -> cctxt.warning "%a" pp_print_error [ err ])
     errs
 
@@ -631,6 +646,10 @@ let commands () =
        @@ stop)
       (fun program storage input cctxt ->
          let open Data_encoding in
+         let print_errors errs =
+           report_errors cctxt errs >>= fun () ->
+           cctxt.error "error running program" >>= fun () ->
+           return () in
          if !trace_stack then
            Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
              cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
@@ -650,10 +669,7 @@ let commands () =
                          stack))
                  trace >>= fun () ->
                return ()
-           | Error errs ->
+           | Error errs -> print_errors errs
-               report_typechecking_errors cctxt errs >>= fun () ->
-               cctxt.error "error running program" >>= fun () ->
-               return ()
          else
            Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
              cctxt.config.block program.ast (storage.ast, input.ast, !amount) >>= function
@@ -663,9 +679,7 @@ let commands () =
                  (print_expr no_locations) output >>= fun () ->
                return ()
            | Error errs ->
-               report_typechecking_errors cctxt errs >>= fun () ->
+               print_errors errs);
-               cctxt.error "error running program" >>= fun () ->
-               return ()) ;
 
     command ~group ~desc: "ask the node to typecheck a program"
       ~args: [ show_types_arg ; emacs_mode_arg ]
@@ -697,10 +711,10 @@ let commands () =
                  match errs with
                  | Ecoproto_error (Script_ir_translator.Ill_formed_type
                                      (Some ("return" | "parameter" | "storage" as field), _) :: errs) :: _ ->
-                     report_typechecking_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
+                     report_errors cctxt [ Ecoproto_error errs ] >>= fun () ->
                      Lwt.return ([], [ List.assoc 0 (List.assoc field program.loc_table), Buffer.contents msg ])
                  | Ecoproto_error (Script_ir_translator.Ill_typed_contract (_, _, _, _, type_map) :: errs) :: _ ->
-                     (report_typechecking_errors cctxt [ Ecoproto_error errs ]  >>= fun () ->
+                     (report_errors cctxt [ Ecoproto_error errs ]  >>= fun () ->
                       let (types, _) = emacs_type_map type_map in
                       let loc = match collect_error_locations errs with
                         | hd :: _ -> hd
@@ -738,9 +752,8 @@ let commands () =
                  return ()
                else return ()
            | Error errs ->
-               report_typechecking_errors
+               report_errors cctxt errs >>= fun () ->
-                 ?show_types:(if !show_types then Some program.ast else None) cctxt errs >>= fun () ->
+               cctxt.error "ill-typed program") ;
-               failwith "ill-typed program") ;
 
     command ~group ~desc: "ask the node to typecheck a data expression"
       (prefixes [ "typecheck" ; "data" ]
@@ -758,8 +771,8 @@ let commands () =
              cctxt.message "Well typed" >>= fun () ->
              return ()
          | Error errs ->
-             report_typechecking_errors cctxt errs >>= fun () ->
+             report_errors cctxt errs >>= fun () ->
-             failwith "ill-typed data") ;
+             cctxt.error "ill-typed data") ;
 
     command ~group
       ~desc: "ask the node to compute the hash of a data expression \
@@ -777,7 +790,7 @@ let commands () =
              return ()
          | Error errs ->
              cctxt.warning "%a" pp_print_error errs  >>= fun () ->
-             failwith "ill-formed data") ;
+             cctxt.error "ill-formed data") ;
 
     command ~group
       ~desc: "ask the node to compute the hash of a data expression \
@@ -804,6 +817,6 @@ let commands () =
              return ()
          | Error errs ->
              cctxt.warning "%a" pp_print_error errs >>= fun () ->
-             failwith "ill-formed data") ;
+             cctxt.error "ill-formed data") ;
 
   ]

src/client/embedded/alpha/client_proto_programs.mli

@@ -18,6 +18,8 @@ val parse_data_type: string -> Script.expr parsed tzresult Lwt.t
 
 val print_storage: Format.formatter -> Script.storage -> unit
 
+val report_errors: Client_commands.context -> error list -> unit Lwt.t
+
 module Program : Client_aliases.Alias with type t = Script.code parsed
 
 val commands: unit -> Client_commands.command list

src/proto/alpha/script_interpreter.ml

@@ -22,6 +22,7 @@ type error += Quota_exceeded
 type error += Overflow of Script.location
 type error += Reject of Script.location
 type error += Division_by_zero of Script.location
+type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error
 
 let () =
   let open Data_encoding in
@@ -56,11 +57,28 @@ let () =
   register_error_kind
     `Temporary
     ~id:"scriptRejectedRuntimeError"
-    ~title: "Script rejected (runtime script error)"
+    ~title: "Script failed (runtime script error)"
-    ~description: ""
+    ~description: "A FAIL instruction was reached"
     (obj1 (req "location" Script.location_encoding))
     (function Reject loc -> Some loc | _ -> None)
-    (fun loc -> Reject loc)
+    (fun loc -> Reject loc);
+  register_error_kind
+    `Temporary
+    ~id:"scriptRuntimeError"
+    ~title: "Script runtime error"
+    ~description: "Toplevel error for all runtime script errors"
+    (obj5
+       (req "contractHandle" Contract.encoding)
+       (req "contractCode" Script.expr_encoding)
+       (req "contractParameterType" ex_ty_enc)
+       (req "contractReturnType" ex_ty_enc)
+       (req "contractStorageType" ex_ty_enc))
+    (function
+      | Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty) ->
+          Some (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty)
+      | _ -> None)
+    (fun (contract, expr, Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty) ->
+       Runtime_contract_error (contract, expr, arg_ty, ret_ty, storage_ty));
 
 (* ---- interpreter ---------------------------------------------------------*)
 
@@ -519,7 +537,9 @@ and execute ?log origination orig source ctxt storage script amount arg qta =
     (parse_lambda ~storage_type ctxt arg_type_full ret_type_full code) >>=? fun lambda ->
   parse_data ctxt arg_type arg >>=? fun arg ->
   parse_data ctxt storage_type storage >>=? fun storage ->
-  interp ?log origination qta orig source amount ctxt lambda (arg, storage)
+  trace
+    (Runtime_contract_error (source, code, arg_type, ret_type_full, storage_type))
+    (interp ?log origination qta orig source amount ctxt lambda (arg, storage))
   >>=? fun (ret, qta, ctxt, origination) ->
   let ret, storage = ret in
   return (unparse_data storage_type storage,

src/proto/alpha/script_interpreter.mli

@@ -8,11 +8,13 @@
 (**************************************************************************)
 
 open Tezos_context
+open Script_typed_ir
 
 type error += Quota_exceeded
 type error += Overflow of Script.location
 type error += Reject of Script.location
 type error += Division_by_zero of Script.location
+type error += Runtime_contract_error : Contract.t * Script.expr * _ ty * _ ty * _ ty -> error
 
 val dummy_code_fee : Tez.t
 val dummy_storage_fee : Tez.t

src/proto/alpha/script_ir_translator.ml

@@ -1433,14 +1433,24 @@ let parse_script
   = fun ?type_logger ctxt
     { storage; storage_type = init_storage_type }
     { code; arg_type; ret_type; storage_type } ->
-    (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) ->
+    trace
-    (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) ->
+      (Ill_formed_type (Some "parameter", arg_type))
-    (Lwt.return (parse_ty init_storage_type)) >>=? fun (Ex_ty init_storage_type) ->
+      (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) ->
-    (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) ->
+    trace
+      (Ill_formed_type (Some "return", ret_type))
+      (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) ->
+    trace
+      (Ill_formed_type (Some "initial storage", init_storage_type))
+      (Lwt.return (parse_ty init_storage_type)) >>=? fun (Ex_ty init_storage_type) ->
+    trace
+      (Ill_formed_type (Some "storage", storage_type))
+      (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) ->
     let arg_type_full = Pair_t (arg_type, storage_type) in
     let ret_type_full = Pair_t (ret_type, storage_type) in
     Lwt.return (ty_eq init_storage_type storage_type) >>=? fun (Eq _) ->
-    parse_data ?type_logger ctxt storage_type storage >>=? fun storage ->
+    trace
+      (Ill_typed_data (None, storage, storage_type))
+      (parse_data ?type_logger ctxt storage_type storage) >>=? fun storage ->
     trace
       (Ill_typed_contract (code, arg_type, ret_type, storage_type, []))
       (parse_lambda ctxt ~storage_type ?type_logger arg_type_full ret_type_full code) >>=? fun code ->
@@ -1573,6 +1583,15 @@ let typecheck_data
 
 (* ---- Error registration --------------------------------------------------*)
 
+let ex_ty_enc =
+    Data_encoding.conv
+      (fun (Ex_ty ty) -> unparse_ty ty)
+      (fun expr ->
+         match parse_ty expr with
+         | Ok (Ex_ty ty) -> Ex_ty ty
+         | _ -> Ex_ty Unit_t (* FIXME: ? *))
+      Script.expr_encoding
+
 let () =
   let open Data_encoding in
   let located enc =
@@ -1602,14 +1621,6 @@ let () =
                   "string", String_kind ;
                   "primitiveApplication", Prim_kind ;
                   "sequence", Seq_kind ] in
-  let ex_ty_enc =
-    conv
-      (fun (Ex_ty ty) -> unparse_ty ty)
-      (fun expr ->
-         match parse_ty expr with
-         | Ok (Ex_ty ty) -> Ex_ty ty
-         | _ -> Ex_ty Unit_t (* FIXME: ? *))
-      Script.expr_encoding in
   let ex_stack_ty_enc =
     let rec unfold = function
       | Ex_stack_ty (Item_t (ty, rest)) ->
@@ -1671,7 +1682,7 @@ let () =
     ~id:"invalidExpressionKindTypeError"
     ~title: "Invalid expression kind (typechecking error)"
     ~description:
-      "In a ascript or data expression, an expression was of the wrong kind \
+      "In a script or data expression, an expression was of the wrong kind \
        (for instance a string where only a primitive applications can appear)."
     (located (obj2
                 (req "expectedKinds" (list kind_enc))
@@ -1686,7 +1697,7 @@ let () =
     ~id:"invalidPrimitiveNamespaceTypeError"
     ~title: "Invalid primitive namespace (typechecking error)"
     ~description:
-      "In a ascript or data expression, a primitive was of the wrong namespace."
+      "In a script or data expression, a primitive was of the wrong namespace."
     (located (obj3
                 (req "primitiveName" string)
                 (req "expectedNamespace" namespace_enc)

src/utils/error_monad.ml

@@ -378,7 +378,7 @@ let () =
     | Unclassified msg -> Some msg
     | error ->
         let msg = Obj.(extension_name @@ extension_constructor error) in
-        Some ("Unclassified error: " ^ msg ^ ".") in
+        Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in
   let title = "Generic error" in
   let description =  "An unclassified error" in
   let encoding_case =