Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht-dev

src/bin/cli.ml

@@ -121,7 +121,7 @@ let compile_file =
     let%bind typed,_    = Compile.Of_simplified.compile simplified in
     let%bind mini_c     = Compile.Of_typed.compile typed in
     let%bind michelson  = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
-    let%bind contract   = Compile.Of_mini_c.build_contract michelson in
+    let%bind contract   = Compile.Of_michelson.build_contract michelson in
     ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract
   in
   let term =
@@ -137,7 +137,7 @@ let measure_contract =
     let%bind typed,_    = Compile.Of_simplified.compile simplified in
     let%bind mini_c     = Compile.Of_typed.compile typed in
     let%bind michelson  = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in
-    let%bind contract   = Compile.Of_mini_c.build_contract michelson in
+    let%bind contract   = Compile.Of_michelson.build_contract michelson in
     let open Tezos_utils in
     ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract)
   in
@@ -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
@@ -162,13 +157,15 @@ let compile_parameter =
     let      env             = Ast_typed.program_environment typed_prg in
     let%bind (_contract: Tezos_utils.Michelson.michelson) =
       (* fails if the given entry point is not a valid contract *)
-      Compile.Of_mini_c.build_contract michelson_prg in
+      Compile.Of_michelson.build_contract michelson_prg in
 
     let%bind v_syntax         = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
     let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in
     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_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in
+    let%bind ()               = Compile.Of_michelson.assert_equal_contract_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 +207,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
@@ -222,13 +214,15 @@ let compile_storage =
     let      env             = Ast_typed.program_environment typed_prg in
     let%bind (_contract: Tezos_utils.Michelson.michelson) =
       (* fails if the given entry point is not a valid contract *)
-      Compile.Of_mini_c.build_contract michelson_prg in
+      Compile.Of_michelson.build_contract michelson_prg in
 
     let%bind v_syntax         = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
     let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in
     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_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in
+    let%bind ()               = Compile.Of_michelson.assert_equal_contract_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
@@ -248,7 +242,7 @@ let dry_run =
     let%bind michelson_prg   = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
     let%bind (_contract: Tezos_utils.Michelson.michelson) =
       (* fails if the given entry point is not a valid contract *)
-      Compile.Of_mini_c.build_contract michelson_prg in
+      Compile.Of_michelson.build_contract michelson_prg in
 
     let%bind v_syntax          = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in
     let%bind simplified        = Compile.Of_source.compile_contract_input storage input v_syntax in

src/bin/expect_tests/contract_tests.ml

@@ -16,6 +16,18 @@ let%expect_test _ =
   run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ;
   [%expect {| 628 bytes |}] ;
 
+  run_ligo_good [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
+  [%expect {| (Left (Left 1)) |}] ;
+
+  run_ligo_good [ "compile-storage" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
+  [%expect {| (Pair (Pair {} {}) 3) |}] ;
+
+  run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
+  [%expect {| ligo: different kinds:  {"a":"record[next_id -> nat , cards -> (TO_Map (nat,record[card_pattern -> nat , card_owner -> address])) , card_patterns -> (TO_Map (nat,record[quantity -> nat , coefficient -> mutez]))]","b":"sum[Transfer_single -> record[destination -> address , card_to_transfer -> nat] , Sell_single -> record[card_to_sell -> nat] , Buy_single -> record[card_to_buy -> nat]]"} |}] ;
+
+  run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
+  [%expect {| ligo: different kinds:  {"a":"sum[Transfer_single -> record[destination -> address , card_to_transfer -> nat] , Sell_single -> record[card_to_sell -> nat] , Buy_single -> record[card_to_buy -> nat]]","b":"record[next_id -> nat , cards -> (TO_Map (nat,record[card_pattern -> nat , card_owner -> address])) , card_patterns -> (TO_Map (nat,record[quantity -> nat , coefficient -> mutez]))]"} |}] ;
+
   ()
 
 let%expect_test _ =

src/main/compile/of_michelson.ml

@@ -0,0 +1,32 @@
+open Tezos_utils
+open Proto_alpha_utils
+open Trace
+
+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") @@
+    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") @@
+    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") @@
+    Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
+  ok contract
+
+type check_type = Check_parameter | Check_storage
+let assert_equal_contract_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 ()

src/main/compile/of_mini_c.ml

@@ -1,5 +1,4 @@
 open Mini_c
-open Tezos_utils
 open Proto_alpha_utils
 open Trace
 
@@ -32,18 +31,3 @@ let aggregate_and_compile_contract = fun program name ->
 
 let aggregate_and_compile_expression = fun program exp ->
   aggregate_and_compile program (ExpressionForm exp)
-
-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") @@
-    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") @@
-    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") @@
-    Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
-  ok contract

src/main/compile/of_typed.ml

@@ -6,3 +6,19 @@ let compile : Ast_typed.program -> Mini_c.program result = fun p ->
 
 let compile_expression : annotated_expression -> Mini_c.expression result = fun e ->
   Transpiler.transpile_annotated_expression e
+
+type check_type = Check_parameter | Check_storage
+let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.value -> unit result =
+    fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") (
+  let%bind entry_point = Ast_typed.get_entry contract entry in
+  match entry_point.type_annotation.type_value' with
+  | T_arrow (args,_) -> (
+      match args.type_value' with
+      | T_tuple [param_exp;storage_exp] -> (
+          match c with
+          | Check_parameter -> assert_type_value_eq (param_exp,   param.type_annotation)
+          | Check_storage   -> assert_type_value_eq (storage_exp, param.type_annotation)
+      )
+      | _ -> dummy_fail
+  )
+  | _ -> dummy_fail )

src/stages/ast_typed/combinators.ml

@@ -138,7 +138,7 @@ let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_
 
 let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with
   | T_arrow (a,r) -> ok (a,r)
-  | _ -> simple_fail "not a tuple"
+  | _ -> simple_fail "not a function"
 
 let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with
   | T_sum m -> ok m

src/test/coase_tests.ml

@@ -26,7 +26,7 @@ let compile_main () =
   let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
   let%bind (_contract: Tezos_utils.Michelson.michelson) =
     (* fails if the given entry point is not a valid contract *)
-    Ligo.Compile.Of_mini_c.build_contract michelson_prg in
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
   ok ()
 
 open Ast_simplified

src/test/multisig_tests.ml

@@ -23,7 +23,7 @@ let compile_main () =
   let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
   let%bind (_contract: Tezos_utils.Michelson.michelson) =
     (* fails if the given entry point is not a valid contract *)
-    Ligo.Compile.Of_mini_c.build_contract michelson_prg in
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
   ok ()
 
 open Ast_simplified

src/test/multisig_v2_tests.ml

@@ -23,7 +23,7 @@ let compile_main () =
   let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
   let%bind (_contract: Tezos_utils.Michelson.michelson) =
     (* fails if the given entry point is not a valid contract *)
-    Ligo.Compile.Of_mini_c.build_contract michelson_prg in
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
   ok ()
 
 open Ast_simplified

src/test/replaceable_id_tests.ml

@@ -23,7 +23,7 @@ let compile_main () =
   let%bind michelson_prg   = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
   let%bind (_contract: Tezos_utils.Michelson.michelson) =
     (* fails if the given entry point is not a valid contract *)
-    Ligo.Compile.Of_mini_c.build_contract michelson_prg in
+    Ligo.Compile.Of_michelson.build_contract michelson_prg in
   ok ()
 open Ast_simplified
 

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