diff --git a/src/bin/cli.ml b/src/bin/cli.ml index e3f2ff2ec..aeaa723c2 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -102,7 +102,7 @@ module Run = Ligo.Run.Of_michelson let compile_file = let f source_file entry_point syntax display_format michelson_format = toplevel ~display_format @@ - let%bind contract = Compile.source_to_michelson_contract (Syntax_name syntax) source_file entry_point in + let%bind (contract,_) = Compile.source_to_michelson_contract (Syntax_name syntax) source_file entry_point in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract in let term = @@ -114,7 +114,7 @@ let compile_file = let measure_contract = let f source_file entry_point syntax display_format = toplevel ~display_format @@ - let%bind contract = Compile.source_to_michelson_contract (Syntax_name syntax) source_file entry_point in + let%bind (contract,_) = Compile.source_to_michelson_contract (Syntax_name syntax) source_file entry_point in let open Tezos_utils in ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract) in @@ -139,9 +139,6 @@ let compile_parameter = let doc = "Subcommand: compile parameters to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which calls a contract." in (term , Term.info ~doc cmdname) -(*------------------------------------------------------------------------------------------------------------------------------------- -TODO: This function does not typecheck anything, add the typecheck against the given entrypoint. For now: does the same as compile_parameter --------------------------------------------------------------------------------------------------------------------------------------- *) let compile_storage = let f source_file _entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ @@ -160,14 +157,14 @@ let compile_storage = let dry_run = let f source_file entry_point storage input amount sender source syntax display_format = toplevel ~display_format @@ - let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind (typed_program,state,env) = Compile.source_to_typed (Syntax_name syntax) source_file in - let%bind compiled_param = Compile.source_contract_input_to_michelson_value_as_function ~env ~state (storage,input) v_syntax in - let%bind michelson = Compile.typed_to_michelson_contract_as_exp typed_program entry_point in - let%bind args_michelson = Run.evaluate_michelson compiled_param in - let%bind options = Run.make_dry_run_options {amount ; sender ; source } in - let%bind michelson_output = Run.run_contract ~options michelson.expr michelson.expr_ty args_michelson true in - let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_program entry_point michelson_output in + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in + let%bind (_,(typed_program,state,env)) = Compile.source_to_michelson_contract (Syntax_name syntax) source_file entry_point in + let%bind compiled_param = Compile.source_contract_input_to_michelson_value_as_function ~env ~state (storage,input) v_syntax in + let%bind michelson = Compile.typed_to_michelson_contract_as_exp typed_program entry_point in + let%bind args_michelson = Run.evaluate_michelson compiled_param in + let%bind options = Run.make_dry_run_options {amount ; sender ; source } in + let%bind michelson_output = Run.run_contract ~options michelson.expr michelson.expr_ty args_michelson true in + let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_program entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 239a960d7..eb28a2f04 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -50,11 +50,14 @@ let compile_contract_as_exp = fun program name -> 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 - (*TODO : bind pair trace_tzresult_lwt ? *) - let%bind (param_michelson : Tezos_raw_protocol_005_PsBabyM1.Alpha_context.Script.node) = - Trace.trace_tzresult_lwt (simple_error "TODO") @@ + let%bind param_michelson = + Trace.trace_tzresult_lwt (simple_error "Could not unparse contract lambda's parameter") @@ Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in - let%bind (storage_michelson : Tezos_raw_protocol_005_PsBabyM1.Alpha_context.Script.node) = - Trace.trace_tzresult_lwt (simple_error "TODO") @@ + let%bind storage_michelson = + Trace.trace_tzresult_lwt (simple_error "Could not unparse contract lambda's storage") @@ Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in - ok @@ Michelson.contract param_michelson storage_michelson compiled.expr + let contract = Michelson.contract param_michelson storage_michelson compiled.expr in + let%bind () = + Trace.trace_tzresult_lwt (simple_error "Invalid contract") @@ + Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in + ok contract diff --git a/src/main/compile/wrapper.ml b/src/main/compile/wrapper.ml index a38af4b46..f8579e5e1 100644 --- a/src/main/compile/wrapper.ml +++ b/src/main/compile/wrapper.ml @@ -49,6 +49,7 @@ let typed_to_michelson_contract_as_exp (* produce a michelson contract e.g. the following sequence K_param ; K_storage ; K_code *) let source_to_michelson_contract syntax source_file entry_point = - let%bind (typed,_,_) = source_to_typed syntax source_file in + let%bind (typed,state,env) = source_to_typed syntax source_file in let%bind michelson = typed_to_michelson_contract_as_exp typed entry_point in - Of_mini_c.build_contract michelson + let%bind contract = Of_mini_c.build_contract michelson in + ok (contract, (typed,state,env)) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index 14618d8ba..5f7cc6590 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -147,18 +147,16 @@ let f = fun x -> let (Ex x') = x in x' (* la ca sort *) ('b ty * field_annot option * var_annot option) * type_annot option * bool -> ('a, 'b) pair ty *) -let fetch_contract_args (contract_ty:ex_ty) = +let fetch_lambda_types (contract_ty:ex_ty) = match contract_ty with - | Ex_ty (Contract_t (in_ty,_)) -> ok (Ex_ty in_ty, Ex_ty in_ty) | Ex_ty (Lambda_t (in_ty, out_ty, _)) -> ok (Ex_ty in_ty, Ex_ty out_ty) - | _ -> - simple_fail "mock" + | _ -> simple_fail "failed to fetch lambda types" (* type run_res = Failwith of failwith_res | Success of ex_typed_value let run_bis ?options (exp:Michelson.t) (input_michelson:Michelson.t) (is_contract:bool) : run_res result = *) let run_contract ?options (exp:Michelson.t) (exp_type:ex_ty) (input_michelson:Michelson.t) (is_contract:bool) : ex_typed_value result = let open! Tezos_raw_protocol_005_PsBabyM1 in - let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_contract_args exp_type in + let%bind (Ex_ty input_ty, Ex_ty output_ty) = fetch_lambda_types exp_type in let%bind input = Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ Memory_proto_alpha.parse_michelson_data input_michelson input_ty 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 c60baea92..99887c721 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 @@ -1100,6 +1100,11 @@ let unparse_ty_michelson ty = Script_ir_translator.unparse_ty dummy_environment.tezos_context ty >>=?? fun (n,_) -> return n +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 () + type 'a interpret_res = | Succeed of 'a stack | Fail of Script_repr.expr