diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index 52d4f7b25..0aa3cfcd8 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -42,6 +42,7 @@ let t_function param result ?s () : type_value = make_t (T_function (param, resu let t_shallow_closure param result ?s () : type_value = make_t (T_function (param, result)) s let get_type_annotation (x:annotated_expression) = x.type_annotation +let get_type' (x:type_value) = x.type_value' let get_environment (x:annotated_expression) = x.environment let get_expression (x:annotated_expression) = x.expression @@ -156,7 +157,10 @@ let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_address s : expression = E_literal (Literal_address s) let e_operation s : expression = E_literal (Literal_operation s) +let e_lambda l : expression = E_lambda l let e_pair a b : expression = E_tuple [a; b] +let e_application a b : expression = E_application (a , b) +let e_variable v : expression = E_variable v let e_list lst : expression = E_list lst let e_a_unit = make_a_e e_unit (t_unit ()) @@ -168,9 +172,12 @@ let e_a_string s = make_a_e (e_string s) (t_string ()) let e_a_address s = make_a_e (e_address s) (t_address ()) let e_a_pair a b = make_a_e (e_pair a b) (t_pair a.type_annotation b.type_annotation ()) let e_a_some s = make_a_e (e_some s) (t_option s.type_annotation ()) +let e_a_lambda l = make_a_e (e_lambda l) (t_function l.input_type l.output_type ()) let e_a_none t = make_a_e e_none (t_option t ()) let e_a_tuple lst = make_a_e (E_tuple lst) (t_tuple (List.map get_type_annotation lst) ()) let e_a_record r = make_a_e (e_record r) (t_record (SMap.map get_type_annotation r) ()) +let e_a_application a b = make_a_e (e_application a b) (get_type_annotation b) +let e_a_variable v ty = make_a_e (e_variable v) ty let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_annotation) r) ()) let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ()) let e_a_list lst t = make_a_e (e_list lst) (t_list t ()) diff --git a/src/ligo/ast_typed/combinators_environment.ml b/src/ligo/ast_typed/combinators_environment.ml index 3d715c588..e8ca37530 100644 --- a/src/ligo/ast_typed/combinators_environment.ml +++ b/src/ligo/ast_typed/combinators_environment.ml @@ -18,6 +18,7 @@ let e_a_empty_record r = e_a_record r Environment.full_empty let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty let e_a_empty_list lst t = e_a_list lst t Environment.full_empty let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty +let e_a_empty_lambda l = e_a_lambda l Environment.full_empty open Environment diff --git a/src/ligo/ast_typed/misc.ml b/src/ligo/ast_typed/misc.ml index 419f930e0..b562be0ff 100644 --- a/src/ligo/ast_typed/misc.ml +++ b/src/ligo/ast_typed/misc.ml @@ -375,3 +375,43 @@ let merge_annotation (a:type_value option) (b:type_value option) : type_value re | _, None -> ok a | _, Some _ -> ok b +open Combinators + +let program_to_main : program -> string -> lambda result = fun p s -> + let%bind (main , input_type , output_type) = + let pred = fun d -> + match d with + | Declaration_constant (d , _) when d.name = s -> Some d.annotated_expression + | Declaration_constant _ -> None + in + let%bind main = + trace_option (simple_error "no main with given name") @@ + List.find_map (Function.compose pred Location.unwrap) p in + let%bind (input_ty , output_ty) = + match (get_type' @@ get_type_annotation main) with + | T_function (i , o) -> ok (i , o) + | _ -> simple_fail "program main isn't a function" in + ok (main , input_ty , output_ty) + in + let body = + let aux : declaration -> instruction = fun d -> + match d with + | Declaration_constant (d , _) -> I_declaration d in + List.map (Function.compose aux Location.unwrap) p in + let env = + let aux = fun _ d -> + match d with + | Declaration_constant (_ , env) -> env in + List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in + let binder = "@contract_input" in + let result = + let input_expr = e_a_variable binder input_type env in + let main_expr = e_a_variable s (get_type_annotation main) env in + e_a_application main_expr input_expr env in + ok { + binder ; + input_type ; + output_type ; + body ; + result ; + } diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index 33828c320..585d4d314 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -522,15 +522,6 @@ let translate_program (p:program) (entry:string) : compiled_program result = let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) -let translate_contract : program -> string -> michelson result = fun p e -> - let%bind main = get_main p e in - let%bind (param_ty , storage_ty) = Combinators.get_t_pair main.input in - let%bind param_michelson = Compiler_type.type_ param_ty in - let%bind storage_michelson = Compiler_type.type_ storage_ty in - let%bind { body = code } = translate_program p e in - let contract = Michelson.contract param_michelson storage_michelson code in - ok contract - let translate_entry (p:anon_function) : compiled_program result = let {input;output} : anon_function = p in let%bind body = @@ -539,3 +530,11 @@ let translate_entry (p:anon_function) : compiled_program result = let%bind input = Compiler_type.Ty.type_ input in let%bind output = Compiler_type.Ty.type_ output in ok ({input;output;body}:compiled_program) + +let translate_contract : anon_function -> michelson result = fun f -> + let%bind compiled_program = translate_entry f in + let%bind (param_ty , storage_ty) = Combinators.get_t_pair f.input 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_program.body in + ok contract diff --git a/src/ligo/contracts/dispatch-counter.ligo b/src/ligo/contracts/dispatch-counter.ligo new file mode 100644 index 000000000..a24156ff0 --- /dev/null +++ b/src/ligo/contracts/dispatch-counter.ligo @@ -0,0 +1,16 @@ +type action is +| Increment of int +| Decrement of int + +function increment(const i : int ; const n : int) : int is + block { skip } with (i + n) + +function decrement(const i : int ; const n : int) : int is + block { skip } with (i - n) + +function main (const p : action ; const s : int) : (list(operation) * int) is + block {skip} with ((nil : operation), + case p of + | Increment n -> increment(s , n) + | Decrement n -> decrement(s , n) + end) diff --git a/src/ligo/main/contract.ml b/src/ligo/main/contract.ml index 98d673483..18db9cc61 100644 --- a/src/ligo/main/contract.ml +++ b/src/ligo/main/contract.ml @@ -51,8 +51,8 @@ let transpile_value (e:Ast_typed.annotated_expression) : Mini_c.value result = let%bind f = let open Transpiler in - let (f, t) = functionalize e in - let%bind main = translate_main f t in + let (f , _) = functionalize e in + let%bind main = translate_main f in ok main in @@ -72,14 +72,15 @@ let compile_contract_file : string -> string -> string result = fun source entry let%bind typed = trace (simple_error "typing") @@ Typer.type_program simplified in - let%bind () = - assert_valid_entry_point typed entry_point in + let%bind main_typed = + trace (simple_error "getting typed main") @@ + Ast_typed.program_to_main typed entry_point in let%bind mini_c = trace (simple_error "transpiling") @@ - Transpiler.translate_program typed in + Transpiler.translate_main main_typed in let%bind michelson = trace (simple_error "compiling") @@ - Compiler.translate_contract mini_c entry_point in + Compiler.translate_contract mini_c in let str = Format.asprintf "%a" Micheline.Michelson.pp_stripped michelson in ok str diff --git a/src/ligo/main/main.ml b/src/ligo/main/main.ml index a8debaf63..34bd70fe1 100644 --- a/src/ligo/main/main.ml +++ b/src/ligo/main/main.ml @@ -31,8 +31,8 @@ let transpile_value (e:AST_Typed.annotated_expression) : Mini_c.value result = let%bind f = let open Transpiler in - let (f, t) = functionalize e in - let%bind main = translate_main f t in + let (f , _) = functionalize e in + let%bind main = translate_main f in ok main in diff --git a/src/ligo/test/coase_tests.ml b/src/ligo/test/coase_tests.ml index ca5fc18bb..d3e91267b 100644 --- a/src/ligo/test/coase_tests.ml +++ b/src/ligo/test/coase_tests.ml @@ -126,6 +126,45 @@ let buy () = in ok () +let dispatch_buy () = + let%bind program = get_program () in + let%bind () = + let make_input = fun n -> + let buy_action = ez_e_a_record [ + ("card_to_buy" , e_a_nat 0) ; + ] in + let action = e_a_constructor "Buy_single" buy_action in + let storage = basic 100 1000 (cards_ez first_owner n) (2 * n) in + e_a_pair action storage + in + let make_expected = fun n -> + let ops = e_a_list [] t_operation in + let storage = + let cards = + cards_ez first_owner n @ + [(e_a_nat (2 * n) , card (e_a_address second_owner))] + in + basic 101 1000 cards ((2 * n) + 1) in + e_a_pair ops storage + in + let%bind () = + let%bind amount = + trace_option (simple_error "getting amount for run") @@ + Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 10000000000 in + let options = Memory_proto_alpha.make_options ~amount () in + expect_eq_n_pos_small ~options program "main" make_input make_expected in + let%bind () = + let%bind amount = + trace_option (simple_error "getting amount for run") @@ + Memory_proto_alpha.Alpha_context.Tez.of_mutez @@ Int64.of_int 0 in + let options = Memory_proto_alpha.make_options ~amount () in + trace_strong (simple_error "could buy without money") @@ + Assert.assert_fail + @@ expect_eq_n_pos_small ~options program "buy_single" make_input make_expected in + ok () + in + ok () + let transfer () = let%bind program = get_program () in let%bind () = @@ -190,6 +229,7 @@ let sell () = let main = "Coase (End to End)", [ test "buy" buy ; + test "dispatch buy" dispatch_buy ; test "transfer" transfer ; test "sell" sell ; ] diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index a9104a564..ed6440a70 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -390,6 +390,16 @@ let super_counter_contract () : unit result = e_a_pair (e_a_list [] t_operation) (e_a_int (op 42 n)) in expect_eq_n program "main" make_input make_expected +let dispatch_counter_contract () : unit result = + let%bind program = type_file "./contracts/dispatch-counter.ligo" in + let make_input = fun n -> + let action = if n mod 2 = 0 then "Increment" else "Decrement" in + e_a_pair (e_a_constructor action (e_a_int n)) (e_a_int 42) in + let make_expected = fun n -> + let op = if n mod 2 = 0 then (+) else (-) in + e_a_pair (e_a_list [] t_operation) (e_a_int (op 42 n)) in + expect_eq_n program "main" make_input make_expected + let basic_mligo () : unit result = let%bind typed = mtype_file "./contracts/basic.mligo" in let%bind result = Ligo.easy_evaluate_typed "foo" typed in @@ -431,6 +441,7 @@ let main = "Integration (End to End)", [ test "#include directives" include_ ; test "counter contract" counter_contract ; test "super counter contract" super_counter_contract ; + test "dispatch counter contract" dispatch_counter_contract ; test "closure" closure ; test "shared function" shared_function ; test "higher order" higher_order ; diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 40b91042f..0f029f47c 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -497,7 +497,7 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements -let translate_main (l:AST.lambda) (_t:AST.type_value) : anon_function result = +let translate_main (l:AST.lambda) : anon_function result = let%bind expr = translate_lambda Environment.empty l in match Combinators.Expression.get_content expr with | E_literal (D_function f) -> ok f @@ -516,7 +516,7 @@ let functionalize (e:AST.annotated_expression) : AST.lambda * AST.type_value = }, Combinators.(t_function (t_unit ()) t ()) let translate_entry (lst:AST.program) (name:string) : anon_function result = - let%bind (lst', l, tv) = + let%bind (lst', l, _) = let rec aux acc (lst:AST.program) = match lst with | [] -> None @@ -540,7 +540,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result = let l' = {l with body = lst' @ l.body} in let r = trace (simple_error "translating entry") @@ - translate_main l' tv in + translate_main l' in r open Combinators