WIP: introduce compiled_expression and unify dry-run and compile-contract

src/bin/cli.ml

@@ -163,10 +163,10 @@ let dry_run =
     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_program typed_program entry_point 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 ~options michelson args_michelson 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

src/main/compile/of_mini_c.ml

@@ -1,8 +1,9 @@
-open Trace
 open Mini_c
 open Tezos_utils
+open Proto_alpha_utils
+open Trace
 
-let compile_expression_as_function : expression -> _ result = fun e ->
+let compile_expression_as_function : expression -> Compiler.compiled_program result = fun e ->
   let (input , output) = t_unit , e.type_value in
   let%bind body = Compiler.Program.translate_expression e Compiler.Environment.empty in
   let body = Self_michelson.optimize body in
@@ -11,7 +12,7 @@ let compile_expression_as_function : expression -> _ result = fun e ->
   let open! Compiler.Program in
   ok { input ; output ; body }
 
-let compile_function = fun e ->
+let compile_function : expression -> Compiler.compiled_program result = fun e ->
   let%bind (input , output) = get_t_function e.type_value in
   let%bind body = get_function e in
   let%bind body = Compiler.Program.translate_function_body body [] input in
@@ -30,15 +31,30 @@ let compile_function_entry = fun program name ->
   let aggregated = Self_mini_c.all_expression aggregated in
   compile_function aggregated
 
-let compile_contract_entry = fun program name ->
+(* new *)
+
+let compile_contract : expression -> Compiler.compiled_expression result = fun e ->
+  let%bind (input , _) = get_t_function e.type_value in
+  let%bind body = get_function e in
+  let%bind body = Compiler.Program.translate_function_body body [] input in
+  let expr = Self_michelson.optimize body in
+  let%bind expr_ty = Compiler.Type.Ty.type_ e.type_value in
+  let open! Compiler.Program in
+  ok { expr_ty ; expr }
+
+let compile_contract_as_exp = fun program name ->
   let%bind aggregated = aggregate_entry program name false in
   let aggregated = Self_mini_c.all_expression aggregated in
-  let%bind compiled = compile_function aggregated in
-  let%bind (param_ty , storage_ty) =
-    let%bind fun_ty = get_t_function aggregated.type_value in
-    Mini_c.get_t_pair (fst fun_ty)
-  in
-  let%bind param_michelson = Compiler.Type.type_ param_ty in
-  let%bind storage_michelson = Compiler.Type.type_ storage_ty in
-  let contract = Michelson.contract param_michelson storage_michelson compiled.body in
-  ok contract
+  compile_contract aggregated
+
+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") @@
+    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") @@
+    Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in
+  ok @@ Michelson.contract param_michelson storage_michelson compiled.expr

src/main/compile/wrapper.ml

@@ -31,15 +31,6 @@ let simplified_to_compiled_program
   let%bind (typed,_) = Of_simplified.compile_expression ~env ~state exp in
   typed_expression_to_michelson_value_as_function typed
 
-let typed_to_michelson_contract
-    (typed: Ast_typed.program) (entry_point:string) : Michelson.michelson result =
-  let%bind mini_c = Of_typed.compile typed in
-  Of_mini_c.compile_contract_entry mini_c entry_point
-
-let source_to_michelson_contract syntax source_file entry_point =
-  let%bind (typed,_,_) = source_to_typed syntax source_file in
-  typed_to_michelson_contract typed entry_point
-
 let source_expression_to_michelson_value_as_function ~env ~state parameter syntax =
   let%bind typed  = source_to_typed_expression ~env ~state parameter syntax in
   let%bind mini_c = Of_typed.compile_expression typed in
@@ -49,3 +40,15 @@ let source_contract_input_to_michelson_value_as_function ~env ~state (storage,pa
   let%bind simplified = Of_source.compile_contract_input storage parameter syntax in
   let%bind typed,_    = Of_simplified.compile_expression ~env ~state simplified in
   typed_expression_to_michelson_value_as_function typed
+
+(* new *)
+let typed_to_michelson_contract_as_exp
+    (typed: Ast_typed.program) (entry_point:string) : Compiler.compiled_expression result =
+  let%bind mini_c = Of_typed.compile typed in
+  Of_mini_c.compile_contract_as_exp mini_c entry_point
+
+(* 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 michelson = typed_to_michelson_contract_as_exp typed entry_point in
+  Of_mini_c.build_contract michelson

src/main/run/of_michelson.ml

@@ -123,3 +123,86 @@ let pack_payload (payload:Michelson.t) ty =
     Trace.trace_tzresult_lwt (simple_error "error packing message") @@
     Memory_proto_alpha.pack ty payload in
   ok @@ data
+
+
+(*
+type ex_option =
+Ex_option : 'a option -> ex_option
+
+let f : ex_option -> _ = fun exo ->
+  let (Ex_option x) = exo in
+  match x with
+  | None -> 0
+  | Some x' -> 1 (*x' varialbe de tpy existentiel*)
+   (* Some x' : j'essaie defenir x', et je le sors pas de la function, donc c bon*)
+*)
+
+(*
+type ex = Ex : 'a -> ex
+let f = fun x -> let (Ex x') = x in x' (* la ca sort *)
+*)
+
+  (* | Pair_t :
+      ('a ty * field_annot option * var_annot option) *
+      ('b ty * field_annot option * var_annot option) *
+      type_annot option *
+      bool -> ('a, 'b) pair ty *)
+let fetch_contract_args (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"
+
+(* 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 input =
+    Trace.trace_tzresult_lwt (simple_error "error parsing input") @@
+    Memory_proto_alpha.parse_michelson_data input_michelson input_ty
+  in
+  let (top_level, ty_stack_before, ty_stack_after) =
+    (if is_contract then
+      Script_ir_translator.Toplevel { storage_type = output_ty ; param_type = input_ty ;
+                                      root_name = None ; legacy_create_contract_literal = false }
+    else Script_ir_translator.Lambda) ,
+    Script_typed_ir.Item_t (input_ty, Empty_t, None),
+    Script_typed_ir.Item_t (output_ty, Empty_t, None) in
+  let exp = Michelson.strip_annots exp in
+  let%bind descr =
+    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Memory_proto_alpha.parse_michelson ~top_level exp ty_stack_before ty_stack_after in
+  let open! Memory_proto_alpha.Protocol.Script_interpreter in
+  let%bind (Item(output, Empty)) =
+    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Memory_proto_alpha.interpret ?options descr
+      (Item(input, Empty))
+      in
+  ok (Ex_typed_value (output_ty, output))
+ 
+ (*
+let run_exp ?options (exp:Michelson.t) (*add the type*) : ex_typed_value result =
+  let%bind exp_type =
+    Trace.trace_tzresult_lwt (simple_error "error getting expression type") @@
+    Memory_proto_alpha.parse_michelson_ty exp in
+  let open! Tezos_raw_protocol_005_PsBabyM1 in
+  let (Ex_ty exp_type') = exp_type in
+  let%bind ((top_level : tc_context), ty_stack_before, ty_stack_after) =
+    ok @@ (
+      Script_ir_translator.Lambda,
+      Script_typed_ir.Empty_t,
+      Script_typed_ir.Item_t (exp_type', Empty_t, None) )
+  in
+  let exp = Michelson.strip_annots exp in
+  let%bind descr =
+    Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@
+    Memory_proto_alpha.parse_michelson ~top_level exp ty_stack_before ty_stack_after in
+  let open! Memory_proto_alpha.Protocol.Script_interpreter in
+  let%bind (Item(output, Empty)) =
+    Trace.trace_tzresult_lwt (simple_error "error of execution") @@
+    Memory_proto_alpha.interpret ?options descr Empty in
+    (* TODO stack type : unit::empty *)
+  ok (Ex_typed_value (exp_type', output))
+  *)

src/passes/8-compiler/compiler_program.ml

@@ -456,6 +456,11 @@ type compiled_program = {
   body : michelson ;
 }
 
+type compiled_expression = {
+  expr_ty : ex_ty ;
+  expr : michelson ;
+}
+
 let get_main : program -> string -> (anon_function * _) result = fun p entry ->
   let is_main ((( name , expr), _):toplevel_statement) =
     match Combinators.Expression.(get_content expr , get_type expr)with

src/passes/8-compiler/compiler_program.mli

@@ -15,6 +15,11 @@ type compiled_program = {
   body : michelson ;
 }
 
+type compiled_expression = {
+  expr_ty : ex_ty ;
+  expr : michelson ;
+}
+
 val get_operator : constant -> type_value -> expression list -> predicate result
 val translate_expression : expression -> environment -> michelson result
 val translate_function_body : anon_function -> environment_element list -> type_value -> michelson result