Merge branch '104-seemingly-simple-contract-does-not-typecheck-error-is-uninformative' into 'dev'

Resolve "Seemingly simple contract does not typecheck, error is uninformative"

Closes #104

See merge request ligolang/ligo!290

src/main/compile/of_michelson.ml

@@ -2,20 +2,53 @@ open Tezos_utils
 open Proto_alpha_utils
 open Trace
 
+module Errors = struct
+(*
+  TODO: those errors should have been caught in the earlier stages on the ligo pipeline
+        Here, in case of contract not typechecking, we should write a warning with a "please report"
+        on stderr and print the ill-typed michelson code;
+*)
+  let title_type_check_msg () = "Invalid contract (This might be a compiler bug, please report) "
+  let bad_parameter c () =
+    let message () =
+      let code = Format.asprintf "%a" Michelson.pp c in
+      "bad contract parameter type (some michelson types are forbidden as contract parameter):\n"^code in
+    error title_type_check_msg message
+  let bad_storage c () =
+    let message () =
+      let code = Format.asprintf "%a" Michelson.pp c in
+      "bad storage type (some michelson types are forbidden as contract storage):\n"^code in
+    error title_type_check_msg message
+  let bad_contract c () =
+    let message () =
+      let code = Format.asprintf "%a" Michelson.pp c in
+      "bad contract type (contract entry point is expected to be of the form \"parameter * storage -> list(operation) * storage\"):\n"^code in
+    error title_type_check_msg message
+  let unknown () =
+    let message () =
+      "unknown error" in
+    error title_type_check_msg message
+end
+
 let build_contract : Compiler.compiled_expression -> Michelson.michelson result =
   fun compiled ->
   let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in
   let%bind param_michelson =
-    Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse parameter") @@
+    Trace.trace_tzresult_lwt (simple_error "Could not unparse parameter") @@
     Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in
   let%bind storage_michelson =
-    Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse storage") @@
+    Trace.trace_tzresult_lwt (simple_error "Could not unparse storage") @@
     Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
   let contract = Michelson.contract param_michelson storage_michelson compiled.expr in
-  let%bind () = 
-    Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@
+  let%bind res =
+    Trace.trace_tzresult_lwt (simple_error "Could not typecheck the code") @@
     Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
-  ok contract
+  match res with
+  | Type_checked  -> ok contract
+  | Err_parameter -> fail @@ Errors.bad_parameter contract ()
+  | Err_storage   -> fail @@ Errors.bad_storage contract ()
+  | Err_contract  -> fail @@ Errors.bad_contract contract ()
+  | Err_unknown   -> fail @@ Errors.unknown ()
 
 type check_type = Check_parameter | Check_storage
 let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =
@@ -29,4 +62,4 @@ let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> C
     let%bind _ = 
       Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@
       Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in
-    ok ()
+    ok ()

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

@@ -1103,10 +1103,20 @@ let unparse_ty_michelson ty =
   Script_ir_translator.unparse_ty dummy_environment.tezos_context ty >>=??
   fun (n,_) -> return n
 
+type typecheck_res =
+  | Type_checked
+  | Err_parameter | Err_storage | Err_contract
+  | Err_unknown
+
 let typecheck_contract contract =
   let contract' = Tezos_micheline.Micheline.strip_locations contract in
-  Script_ir_translator.typecheck_code dummy_environment.tezos_context contract' >>=??
-  fun _ -> return ()
+  Script_ir_translator.typecheck_code dummy_environment.tezos_context contract' >>= fun x ->
+  match x with
+  | Ok _res -> return Type_checked
+  | Error (Script_tc_errors.Ill_formed_type (Some "parameter", _code, _)::_) -> return Err_parameter
+  | Error (Script_tc_errors.Ill_formed_type (Some "storage", _code, _)::_) -> return Err_storage
+  | Error (Script_tc_errors.Ill_typed_contract (_code, _)::_) -> return @@ Err_contract
+  | Error _ -> return Err_unknown
 
 let assert_equal_michelson_type ty1 ty2 =
   (* alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> *)
@@ -1117,7 +1127,7 @@ type 'a interpret_res =
   | Fail of Script_repr.expr
 
 let failure_interpret
-    ?(options = default_options) 
+    ?(options = default_options)
     (instr:('a, 'b) descr)
     (bef:'a stack) : 'b interpret_res tzresult Lwt.t =
   let {