add tests for dispatch

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 ())

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
 

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 ;
+  }

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

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)

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

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
 

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 ;
   ]

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 ;

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