diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 6ab46b7f6..b0a2c9251 100644 --- a/src/bin/cli.ml +++ b/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 diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 1facce834..fc87bc8cb 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/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 _ = diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml new file mode 100644 index 000000000..5e73d07c2 --- /dev/null +++ b/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 () \ No newline at end of file diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 0ed53895f..4387ca133 100644 --- a/src/main/compile/of_mini_c.ml +++ b/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 diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 2fccdd920..0aa705405 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -5,4 +5,20 @@ let compile : Ast_typed.program -> Mini_c.program result = fun p -> Transpiler.transpile_program p let compile_expression : annotated_expression -> Mini_c.expression result = fun e -> - Transpiler.transpile_annotated_expression e \ No newline at end of file + 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 ) \ No newline at end of file diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 20706a586..c46e39e21 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/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 diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index f2196190d..af091ad88 100644 --- a/src/test/coase_tests.ml +++ b/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 diff --git a/src/test/multisig_tests.ml b/src/test/multisig_tests.ml index 80a17b3d4..d89719c4c 100644 --- a/src/test/multisig_tests.ml +++ b/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 diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 81d0ca395..e42fd62fe 100644 --- a/src/test/multisig_v2_tests.ml +++ b/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 diff --git a/src/test/replaceable_id_tests.ml b/src/test/replaceable_id_tests.ml index ca04640c1..6bf09e95a 100644 --- a/src/test/replaceable_id_tests.ml +++ b/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 diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 99887c721..460494379 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/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