diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml index 5e73d07c2..0b070fb79 100644 --- a/src/main/compile/of_michelson.ml +++ b/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 () \ No newline at end of file + ok () 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 d47b85086..c613c86a4 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 @@ -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 {