better error message when a contract in invalid

This commit is contained in:
Lesenechal Remi 2019-12-11 19:25:17 +01:00
parent c0472629b9
commit df0dfb029b
2 changed files with 6 additions and 7 deletions

View File

@ -35,15 +35,15 @@ let aggregate_and_compile_expression = fun program 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_lambda_parameters compiled.expr_ty in
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 "Could not unparse contract lambda's parameter") @@
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 "Could not unparse contract lambda's storage") @@
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") @@
Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@
Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in
ok contract

View File

@ -19,9 +19,8 @@ let rec map_expression : mapper -> michelson -> michelson result = fun f e ->
| x -> ok x
open Memory_proto_alpha.Protocol.Script_ir_translator
(* fetches lambda first and second parameter (parameter,storage) *)
let fetch_lambda_parameters : ex_ty -> (ex_ty * ex_ty) result =
let error () = simple_fail "failed to fetch lambda parameters" in
let fetch_contract_inputs : ex_ty -> (ex_ty * ex_ty) result =
let error () = simple_fail "Invalid contract: Failed to fetch parameter and storage" in
function
| Ex_ty (Lambda_t (in_ty, _, _)) -> (
match in_ty with