compile_parameter and compile_storage CLI commands now gets their input checked

src/bin/cli.ml

@@ -150,11 +150,6 @@ let measure_contract =
 let compile_parameter =
   let f source_file entry_point expression syntax display_format michelson_format =
     toplevel ~display_format @@
-    (*
-      TODO:
-      source_to_michelson_contract will fail if the entry_point does not point to a michelson contract
-      but we do not check that the type of the parameter matches the type of the given expression
-    *)
     let%bind simplified      = Compile.Of_source.compile source_file (Syntax_name syntax) in
     let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
     let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -169,6 +164,7 @@ let compile_parameter =
     let%bind (typed_param,_)  = Compile.Of_simplified.compile_expression ~env ~state simplified_param in
     let%bind mini_c_param     = Compile.Of_typed.compile_expression typed_param in
     let%bind compiled_param   = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in
+    let%bind ()               = Compile.Of_mini_c.assert_equal_michelson_type Check_parameter michelson_prg compiled_param in
     let%bind value            = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in
     ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
   in
@@ -210,11 +206,6 @@ let interpret =
 let compile_storage =
   let f source_file entry_point expression syntax display_format michelson_format =
     toplevel ~display_format @@
-    (*
-      TODO:
-      source_to_michelson_contract will fail if the entry_point does not point to a michelson contract
-      but we do not check that the type of the storage matches the type of the given expression
-    *)
     let%bind simplified      = Compile.Of_source.compile source_file (Syntax_name syntax) in
     let%bind typed_prg,state = Compile.Of_simplified.compile simplified in
     let%bind mini_c_prg      = Compile.Of_typed.compile typed_prg in
@@ -229,6 +220,7 @@ let compile_storage =
     let%bind (typed_param,_)  = Compile.Of_simplified.compile_expression ~env ~state simplified_param in
     let%bind mini_c_param     = Compile.Of_typed.compile_expression typed_param in
     let%bind compiled_param   = Compile.Of_mini_c.compile_expression mini_c_param in
+    let%bind ()               = Compile.Of_mini_c.assert_equal_michelson_type Check_storage michelson_prg compiled_param in
     let%bind value            = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in
     ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value
   in

src/main/compile/of_mini_c.ml

@@ -47,3 +47,17 @@ let build_contract : Compiler.compiled_expression -> Michelson.michelson result
     Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@
     Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
   ok contract
+
+type check_type = Check_parameter | Check_storage
+let assert_equal_michelson_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result =
+  fun c compiled_prg compiled_param ->
+    let%bind (Ex_ty expected_ty) =
+      let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in
+      match c with
+      | Check_parameter -> ok c_param_ty
+      | Check_storage -> ok c_storage_ty in
+    let (Ex_ty actual_ty) = compiled_param.expr_ty in
+    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 ()

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

@@ -1105,6 +1105,10 @@ let typecheck_contract contract =
   Script_ir_translator.typecheck_code dummy_environment.tezos_context contract' >>=??
   fun _ -> return ()
 
+let assert_equal_michelson_type ty1 ty2 =
+  (* alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> *)
+  alpha_wrap (Script_ir_translator.ty_eq dummy_environment.tezos_context ty1 ty2)
+
 type 'a interpret_res =
   | Succeed of 'a stack
   | Fail of Script_repr.expr