diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 5540d8ea1..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 @@ -157,14 +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_mini_c.assert_equal_michelson_type Check_parameter michelson_prg compiled_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 @@ -213,14 +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_mini_c.assert_equal_michelson_type Check_storage michelson_prg compiled_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 @@ -240,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/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 32572ae13..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,32 +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 - -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 () \ No newline at end of file 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