add variant expression pattern-matching

src/ligo/ast_typed/PP.ml

@@ -103,7 +103,7 @@ and instruction ppf (i:instruction) = match i with
 
 let declaration ppf (d:declaration) =
   match d with
-  | Declaration_constant {name ; annotated_expression = ae} ->
+  | Declaration_constant ({name ; annotated_expression = ae} , _) ->
       fprintf ppf "const %s = %a" name annotated_expression ae
 
 let program ppf (p:program) =

src/ligo/ast_typed/combinators.ml

@@ -171,7 +171,7 @@ let get_a_bool (t:annotated_expression) =
 let get_declaration_by_name : program -> string -> declaration result = fun p name ->
   let aux : declaration -> bool = fun declaration ->
     match declaration with
-    | Declaration_constant d -> d.name = name
+    | Declaration_constant (d , _) -> d.name = name
   in
   trace_option (simple_error "no declaration with given name") @@
   List.find_opt aux @@ List.map Location.unwrap p

src/ligo/ast_typed/types.ml

@@ -14,7 +14,7 @@ type 'a type_name_map = 'a SMap.t
 type program = declaration Location.wrap list
 
 and declaration =
-  | Declaration_constant of named_expression
+  | Declaration_constant of (named_expression * full_environment)
   (* | Macro_declaration of macro_declaration *)
 
 and environment_element = {
@@ -141,7 +141,7 @@ open Trace
 let get_entry (p:program) (entry : string) : annotated_expression result =
   let aux (d:declaration) =
     match d with
-    | Declaration_constant {name ; annotated_expression} when entry = name -> Some annotated_expression
+    | Declaration_constant ({name ; annotated_expression} , _) when entry = name -> Some annotated_expression
     | Declaration_constant _ -> None
   in
   let%bind result =

src/ligo/compiler/compiler_program.ml

@@ -300,15 +300,15 @@ and translate_expression ?(first=false) (expr:expression) : michelson result =
         let%bind restrict_r = Compiler_environment.to_michelson_restrict r.environment in
         let%bind code = ok (seq [
             c' ; i_unpair ;
-            i_if_none (seq [
+            i_if_left (seq [
-                i_pair ;
+                i_swap ; dip i_pair ;
                 l' ;
-                i_unpair ;
+                i_comment "restrict left" ;
                 dip restrict_l ;
               ]) (seq [
-                i_pair ;
+                i_swap ; dip i_pair ;
                 r' ;
-                i_unpair ;
+                i_comment "restrict right" ;
                 dip restrict_r ;
               ])
             ;
@@ -324,7 +324,8 @@ and translate_expression ?(first=false) (expr:expression) : michelson result =
             i_unpair ;
             i_swap ; dip i_pair ;
             body' ;
-            restrict ;
+            i_comment "restrict let" ;
+            dip restrict ;
           ]) in
         return code
       )

src/ligo/contracts/variant-matching.ligo

@@ -0,0 +1,9 @@
+type foobar is
+| Foo of int
+| Bar of bool
+
+function fb(const p : foobar) : int is
+  block { skip } with (case p of
+  | Foo (n) -> n
+  | Bar (t) -> 42
+  end)

src/ligo/contracts/variant.ligo

@@ -6,8 +6,3 @@ const foo : foobar = Foo (42)
 
 const bar : foobar = Bar (True)
 
-function fb(const p : foobar) : int is
-  block { skip } with (case p of
-  | Foo (n) -> n
-  | Bar (t) -> 42
-  end)

src/ligo/main/contract.ml

@@ -40,7 +40,7 @@ include struct
   let assert_valid_entry_point : program -> string -> unit result = fun p e ->
     let%bind declaration = get_declaration_by_name p e in
     match declaration with
-    | Declaration_constant d -> assert_entry_point_type d.annotated_expression.type_annotation
+    | Declaration_constant (d , _) -> assert_entry_point_type d.annotated_expression.type_annotation
 end
 
 let transpile_value
@@ -97,7 +97,7 @@ let compile_contract_parameter : string -> string -> string -> string result = f
       assert_valid_entry_point typed entry_point in
     let%bind declaration = Ast_typed.Combinators.get_declaration_by_name typed entry_point in
     match declaration with
-    | Declaration_constant d -> ok d.annotated_expression.type_annotation
+    | Declaration_constant (d , _) -> ok d.annotated_expression.type_annotation
   in
   let%bind expr =
     let%bind raw =

src/ligo/main/main.ml

@@ -126,7 +126,13 @@ let easy_run_typed_simplified
      Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main.content)
   ) ;
 
-  let%bind typed_value = type_expression input in
+  let%bind typed_value =
+    let env =
+      let last_declaration = Location.unwrap List.(hd @@ rev program) in
+      match last_declaration with
+      | Declaration_constant (_ , env) -> env
+    in
+    type_expression ~env input in
   let%bind mini_c_value = transpile_value typed_value in
 
   let%bind mini_c_result =

src/ligo/test/integration_tests.ml

@@ -22,10 +22,15 @@ let variant () : unit result =
   let%bind () =
     let expected = e_a_constructor "Bar" (e_a_bool true) in
     expect_evaluate program "bar" expected in
-  (* let%bind () =
+  ok ()
-   *   let make_expect = fun n -> (3 * n + 2) in
+
-   *   expect_n_int program "fb" make_expect
+let variant_matching () : unit result =
-   * in *)
+  let%bind program = type_file "./contracts/variant-matching.ligo" in
+  let%bind () =
+    let make_input = fun n -> e_a_constructor "Foo" (e_a_int n) in
+    let make_expected = e_a_int in
+    expect_n program "fb" make_input make_expected
+  in
   ok ()
 
 let closure () : unit result =
@@ -324,6 +329,7 @@ let main = "Integration (End to End)", [
     test "function" function_ ;
     test "complex function" complex_function ;
     test "variant" variant ;
+    test "variant matching" variant_matching ;
     test "closure" closure ;
     test "shared function" shared_function ;
     test "shadow" shadow ;

src/ligo/transpiler/transpiler.ml

@@ -201,7 +201,7 @@ and tree_of_sum : AST.type_value -> (type_name * AST.type_value) Append_tree.t r
 
 and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result =
   let%bind tv = translate_type ae.type_annotation in
-  let return ?(tv = tv) expr =
+  let return ?(tv = tv) ?(env = env) expr =
     (* let%bind env' = transpile_environment ae.environment in *)
     ok @@ Combinators.Expression.make_tpl (expr, tv, env) in
   let f = translate_annotated_expression env in
@@ -374,7 +374,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
             in aux tree'
           in
 
-          let rec aux acc t =
+          let rec aux (acc , env) t =
             let top =
               match acc with
               | None -> expr'
@@ -386,26 +386,26 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
                   List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
                 let env' = Environment.(add (name , tv) @@ extend env) in
                 let%bind body' = translate_annotated_expression env' body in
-                return @@ E_let_in ((name , tv) , top , body')
+                return ~env:env' @@ E_let_in ((name , tv) , top , body')
               )
             | ((`Node (a , b)) , tv) ->
                 let%bind a' =
                   let%bind a_ty = get_t_left tv in
                   let a_var = "left" , a_ty in
                   let env' = Environment.(add a_var @@ extend env) in
-                  let%bind e = aux (Some (Expression.make (E_variable "left") a_ty env')) a in
+                  let%bind e = aux ((Some (Expression.make (E_variable "left") a_ty env')) , env') a in
                   ok (a_var , e)
                 in
                 let%bind b' =
                   let%bind b_ty = get_t_right tv in
                   let b_var = "right" , b_ty in
                   let env' = Environment.(add b_var @@ extend env) in
-                  let%bind e = aux (Some (Expression.make (E_variable "right") b_ty env')) b in
+                  let%bind e = aux ((Some (Expression.make (E_variable "right") b_ty env')) , env') b in
                   ok (b_var , e)
                 in
-                return @@ E_if_left (top , a' , b')
+                return ~env @@ E_if_left (top , a' , b')
           in
-          aux None tree''
+          aux (None , env) tree''
         )
       | AST.Match_list _ | AST.Match_tuple (_, _) ->
           simple_fail "only match bool and option exprs are translated yet"
@@ -456,7 +456,7 @@ and translate_lambda env l =
 
 let translate_declaration env (d:AST.declaration) : toplevel_statement result =
   match d with
-  | Declaration_constant {name;annotated_expression} ->
+  | Declaration_constant ({name;annotated_expression} , _) ->
       let%bind expression = translate_annotated_expression env annotated_expression in
       let tv = Combinators.Expression.get_type expression in
       let env' = Environment.add (name, tv) env in
@@ -495,7 +495,7 @@ let translate_entry (lst:AST.program) (name:string) : anon_function result =
       match lst with
       | [] -> None
       | hd :: tl -> (
-          let (AST.Declaration_constant an) = temp_unwrap_loc hd in
+          let (AST.Declaration_constant (an , _)) = temp_unwrap_loc hd in
           match an.name = name with
           | true -> (
               match an.annotated_expression.expression with

src/ligo/typer/typer.ml

@@ -74,7 +74,7 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
         trace (constant_declaration_error name annotated_expression) @@
         type_annotated_expression env annotated_expression in
       let env' = Environment.add_ez name ae'.type_annotation env in
-      ok (env', Some (O.Declaration_constant (make_n_e name ae')))
+      ok (env', Some (O.Declaration_constant ((make_n_e name ae') , env')))
 
 and type_block_full (e:environment) (b:I.block) : (O.block * environment) result =
   let aux (e, acc:(environment * O.instruction list)) (i:I.instruction) =