add expression pattern-matching

src/ligo/ast_simplified.ml

@@ -66,6 +66,8 @@ and expression =
   (* Data Structures *)
   | Map of (ae * ae) list
   | LookUp of (ae * ae)
+  (* Matching *)
+  | Matching_expr of (ae * matching_expr)
 
 and access =
   | Tuple_access of int
@@ -85,26 +87,30 @@ and b = block
 
 and instruction =
   | Assignment of named_expression
-  | Matching of ae * matching
+  | Matching_instr of ae * matching_instr
   | Loop of ae * b
   | Skip
   | Fail of ae
   | Record_patch of name * access_path * (string * ae) list
 
-and matching =
+and 'a matching =
   | Match_bool of {
-      match_true : b ;
+      match_true : 'a ;
-      match_false : b ;
+      match_false : 'a ;
     }
   | Match_list of {
-      match_nil : b ;
+      match_nil : 'a ;
-      match_cons : name * name * b ;
+      match_cons : name * name * 'a ;
     }
   | Match_option of {
-      match_none : b ;
+      match_none : 'a ;
-      match_some : name * b ;
+      match_some : name * 'a ;
     }
-  | Match_tuple of name list * b
+  | Match_tuple of name list * 'a
+
+and matching_instr = b matching
+
+and matching_expr = annotated_expression matching
 
 let ae expression = {expression ; type_annotation = None}
 
@@ -146,6 +152,8 @@ module PP = struct
         fprintf ppf "lambda (%s:%a) : %a {%a} return %a"
           binder type_expression input_type type_expression output_type
           block body annotated_expression result
+    | Matching_expr (ae, m) ->
+        fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
 
   and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
     fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
@@ -171,15 +179,16 @@ module PP = struct
   and single_record_patch ppf ((p, ae) : string * ae) =
     fprintf ppf "%s <- %a" p annotated_expression ae
 
-  and matching ppf (m:matching) = match m with
+  and matching : type a . (formatter -> a -> unit) -> formatter -> a matching -> unit =
+    fun f ppf m -> match m with
     | Match_tuple (lst, b) ->
-        fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst block b
+        fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b
     | Match_bool {match_true ; match_false} ->
-        fprintf ppf "| True -> %a @.| False -> %a" block match_true block match_false
+        fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
     | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
-        fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" block match_nil hd tl block match_cons
+        fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons
     | Match_option {match_none ; match_some = (some, match_some)} ->
-        fprintf ppf "| None -> %a @.| Some %s -> %a" block match_none some block match_some
+        fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none some f match_some
 
   and instruction ppf (i:instruction) = match i with
     | Skip -> fprintf ppf "skip"
@@ -188,8 +197,8 @@ module PP = struct
     | Loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b
     | Assignment {name;annotated_expression = ae} ->
         fprintf ppf "%s := %a" name annotated_expression ae
-    | Matching (ae, m) ->
+    | Matching_instr (ae, m) ->
-        fprintf ppf "match %a with %a" annotated_expression ae matching m
+        fprintf ppf "match %a with %a" annotated_expression ae (matching block) m
 
   let declaration ppf (d:declaration) = match d with
     | Type_declaration {type_name ; type_expression = te} ->
@@ -227,10 +236,10 @@ module Rename = struct
           let%bind cond' = rename_annotated_expression r cond in
           let%bind body' = rename_block r body in
           ok (Loop (cond', body'))
-      | Matching (ae, m) ->
+      | Matching_instr (ae, m) ->
           let%bind ae' = rename_annotated_expression r ae in
-          let%bind m' = rename_matching r m in
+          let%bind m' = rename_matching rename_block r m in
-          ok (Matching (ae', m'))
+          ok (Matching_instr (ae', m'))
       | Record_patch (v, path, lst) ->
           let aux (x, y) =
             let%bind y' = rename_annotated_expression (filter r v) y in
@@ -246,29 +255,34 @@ module Rename = struct
     and rename_block (r:renamings) (bl:block) : block result =
       bind_map_list (rename_instruction r) bl
 
-    and rename_matching (r:renamings) (m:matching) : matching result =
+    and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result =
+      fun f r m ->
       match m with
       | Match_bool { match_true = mt ; match_false = mf } ->
-          let%bind match_true = rename_block r mt in
+          let%bind match_true = f r mt in
-          let%bind match_false = rename_block r mf in
+          let%bind match_false = f r mf in
           ok (Match_bool {match_true ; match_false})
       | Match_option { match_none = mn ; match_some = (some, ms) } ->
-          let%bind match_none = rename_block r mn in
+          let%bind match_none = f r mn in
-          let%bind ms' = rename_block (filter r some) ms in
+          let%bind ms' = f (filter r some) ms in
           ok (Match_option {match_none ; match_some = (some, ms')})
       | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } ->
-          let%bind match_nil = rename_block r mn in
+          let%bind match_nil = f r mn in
-          let%bind mc' = rename_block (filters r [hd;tl]) mc in
+          let%bind mc' = f (filters r [hd;tl]) mc in
           ok (Match_list {match_nil ; match_cons = (hd, tl, mc')})
       | Match_tuple (lst, body) ->
-          let%bind body' = rename_block (filters r lst) body in
+          let%bind body' = f (filters r lst) body in
           ok (Match_tuple (lst, body'))
 
+    and rename_matching_instruction = fun x -> rename_matching rename_block x
+
+    and rename_matching_expr = fun x -> rename_matching rename_expression x
+
     and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result =
       let%bind expression = rename_expression r ae.expression in
       ok {ae with expression}
 
-    and rename_expression (r:renamings) (e:expression) : expression result =
+    and rename_expression : renamings -> expression -> expression result = fun r e ->
       match e with
       | Literal _ as l -> ok l
       | Constant (name, lst) ->
@@ -315,6 +329,10 @@ module Rename = struct
       | LookUp m ->
           let%bind m' = bind_map_pair (rename_annotated_expression r) m in
           ok (LookUp m')
+      | Matching_expr (ae, m) ->
+          let%bind ae' = rename_annotated_expression r ae in
+          let%bind m' = rename_matching rename_annotated_expression r m in
+          ok (Matching_expr (ae', m'))
   end
 end
 

src/ligo/ast_typed.ml

@@ -67,6 +67,8 @@ and expression =
   (* Data Structures *)
   | Map of (ae * ae) list
   | LookUp of (ae * ae)
+  (* Advanced *)
+  | Matching_expr of (ae * matching_expr)
 
 and value = annotated_expression (* todo (for refactoring) *)
 
@@ -83,25 +85,29 @@ and b = block
 
 and instruction =
   | Assignment of named_expression
-  | Matching of ae * matching
+  | Matching_instr of ae * matching_instr
   | Loop of ae * b
   | Skip
   | Fail of ae
 
-and matching =
+and 'a matching =
   | Match_bool of {
-      match_true : b ;
+      match_true : 'a ;
-      match_false : b ;
+      match_false : 'a ;
     }
   | Match_list of {
-      match_nil : b ;
+      match_nil : 'a ;
-      match_cons : name * name * b ;
+      match_cons : name * name * 'a ;
     }
   | Match_option of {
-      match_none : b ;
+      match_none : 'a ;
-      match_some : (name * type_value) * b ;
+      match_some : (name * type_value) * 'a ;
     }
-  | Match_tuple of name list * b
+  | Match_tuple of name list * 'a
+
+and matching_instr = b matching
+
+and matching_expr = ae matching
 
 open! Ligo_helpers.Trace
 
@@ -165,6 +171,8 @@ module PP = struct
     | Record m -> fprintf ppf "record[%a]" (smap_sep annotated_expression) m
     | Map m -> fprintf ppf "map[%a]" (list_sep assoc_annotated_expression) m
     | LookUp (ds, i) -> fprintf ppf "(%a)[%a]" annotated_expression ds annotated_expression i
+    | Matching_expr (ae, m) ->
+        fprintf ppf "match %a with %a" annotated_expression ae (matching annotated_expression) m
 
   and assoc_annotated_expression ppf : (ae * ae) -> unit = fun (a, b) ->
     fprintf ppf "%a -> %a" annotated_expression a annotated_expression b
@@ -183,15 +191,15 @@ module PP = struct
   and single_record_patch ppf ((s, ae) : string * ae) =
     fprintf ppf "%s <- %a" s annotated_expression ae
 
-  and matching ppf (m:matching) = match m with
+  and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fun f ppf m -> match m with
     | Match_tuple (lst, b) ->
-        fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst block b
+        fprintf ppf "let (%a) = %a" (list_sep (fun ppf -> fprintf ppf "%s")) lst f b
     | Match_bool {match_true ; match_false} ->
-        fprintf ppf "| True -> %a @.| False -> %a" block match_true block match_false
+        fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
     | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} ->
-        fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" block match_nil hd tl block match_cons
+        fprintf ppf "| Nil -> %a @.| %s :: %s -> %a" f match_nil hd tl f match_cons
     | Match_option {match_none ; match_some = (some, match_some)} ->
-        fprintf ppf "| None -> %a @.| Some %s -> %a" block match_none (fst some) block match_some
+        fprintf ppf "| None -> %a @.| Some %s -> %a" f match_none (fst some) f match_some
 
   and instruction ppf (i:instruction) = match i with
     | Skip -> fprintf ppf "skip"
@@ -199,8 +207,8 @@ module PP = struct
     | Loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b
     | Assignment {name;annotated_expression = ae} ->
         fprintf ppf "%s := %a" name annotated_expression ae
-    | Matching (ae, m) ->
+    | Matching_instr (ae, m) ->
-        fprintf ppf "match %a with %a" annotated_expression ae matching m
+        fprintf ppf "match %a with %a" annotated_expression ae (matching block) m
 
   let declaration ppf (d:declaration) =
     match d with

src/ligo/contracts/match.ligo

@@ -15,3 +15,10 @@ function match_option (const o : option(int)) : int is
   | Some(s) -> result := s
   end
   end with result
+
+function match_expr_bool (const i : int) : int is
+  begin skip end with
+  case i = 2 of
+  | True -> 42
+  | False -> 0
+  end

src/ligo/ligo-parser/AST.ml

@@ -345,7 +345,7 @@ and instruction =
 
 and single_instr =
   Cond        of conditional reg
-| Case        of case_instr reg
+| Case_instr  of case_instr reg
 | Assign      of assignment reg
 | Loop        of loop
 | ProcCall    of fun_call
@@ -430,18 +430,35 @@ and case_instr = {
   expr      : expr;
   kwd_of    : kwd_of;
   lead_vbar : vbar option;
-  cases     : cases;
+  cases_instr : cases_instr;
   kwd_end   : kwd_end
 }
 
-and cases = (case reg, vbar) nsepseq reg
+and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
 
-and case = {
+and case_clause_instr = {
   pattern : pattern;
   arrow   : arrow;
   instr   : instruction
 }
 
+and case_expr = {
+  kwd_case  : kwd_case;
+  expr      : expr;
+  kwd_of    : kwd_of;
+  lead_vbar : vbar option;
+  cases_expr: cases_expr;
+  kwd_end   : kwd_end
+}
+
+and cases_expr = (case_clause_expr reg, vbar) nsepseq reg
+
+and case_clause_expr = {
+  pattern : pattern;
+  arrow   : arrow;
+  expr    : expr;
+}
+
 and assignment = {
   lhs    : lhs;
   assign : assign;
@@ -498,7 +515,8 @@ and for_collect = {
 (* Expressions *)
 
 and expr =
-  ELogic  of logic_expr
+| ECase   of case_expr reg
+| ELogic  of logic_expr
 | EArith  of arith_expr
 | EString of string_expr
 | EList   of list_expr
@@ -683,7 +701,7 @@ let type_expr_to_region = function
 | TAlias  {region; _} -> region
 
 let rec expr_to_region = function
-  ELogic  e -> logic_expr_to_region e
+| ELogic  e -> logic_expr_to_region e
 | EArith  e -> arith_expr_to_region e
 | EString e -> string_expr_to_region e
 | EList   e -> list_expr_to_region e
@@ -697,6 +715,7 @@ let rec expr_to_region = function
 | ECall  {region; _}
 | EBytes {region; _}
 | EUnit   region
+| ECase  {region;_}
 | EPar   {region; _} -> region
 
 and tuple_expr_to_region = function
@@ -761,7 +780,7 @@ let path_to_region = function
 
 let instr_to_region = function
   Single Cond                {region; _}
-| Single Case                {region; _}
+| Single Case_instr          {region; _}
 | Single Assign              {region; _}
 | Single Loop While          {region; _}
 | Single Loop For ForInt     {region; _}
@@ -1087,7 +1106,7 @@ and print_instruction = function
 
 and print_single_instr = function
   Cond        {value; _} -> print_conditional value
-| Case        {value; _} -> print_case_instr value
+| Case_instr  {value; _} -> print_case_instr value
 | Assign      assign     -> print_assignment assign
 | Loop        loop       -> print_loop loop
 | ProcCall    fun_call   -> print_fun_call fun_call
@@ -1126,22 +1145,22 @@ and print_if_clause = function
 
 and print_case_instr (node : case_instr) =
   let {kwd_case; expr; kwd_of;
-       lead_vbar; cases; kwd_end} = node in
+       lead_vbar; cases_instr; kwd_end} = node in
   print_token kwd_case "case";
   print_expr  expr;
   print_token kwd_of "of";
   print_token_opt lead_vbar "|";
-  print_cases cases;
+  print_cases_instr cases_instr;
   print_token kwd_end "end"
 
 and print_token_opt = function
          None -> fun _ -> ()
 | Some region -> print_token region
 
-and print_cases {value; _} =
+and print_cases_instr {value; _} =
-  print_nsepseq "|" print_case value
+  print_nsepseq "|" print_case_clause_instr value
 
-and print_case {value; _} =
+and print_case_clause_instr {value; _} =
   let {pattern; arrow; instr} = value in
   print_pattern pattern;
   print_token arrow "->";
@@ -1218,7 +1237,8 @@ and print_bind_to = function
 | None -> ()
 
 and print_expr = function
-  ELogic  e -> print_logic_expr e
+  ECase   {value;_} -> print_case_expr value
+| ELogic  e -> print_logic_expr e
 | EArith  e -> print_arith_expr e
 | EString e -> print_string_expr e
 | EList   e -> print_list_expr e
@@ -1234,6 +1254,25 @@ and print_expr = function
 | ETuple  e -> print_tuple_expr e
 | EPar    e -> print_par_expr e
 
+and print_case_expr (node : case_expr) =
+  let {kwd_case; expr; kwd_of;
+       lead_vbar; cases_expr; kwd_end} = node in
+  print_token kwd_case "case";
+  print_expr  expr;
+  print_token kwd_of "of";
+  print_token_opt lead_vbar "|";
+  print_cases_expr cases_expr;
+  print_token kwd_end "end"
+
+and print_cases_expr {value; _} =
+  print_nsepseq "|" print_case_clause_expr value
+
+and print_case_clause_expr {value; _} =
+  let {pattern; arrow; expr} = value in
+  print_pattern pattern;
+  print_token arrow "->";
+  print_expr expr
+
 and print_map_expr = function
   MapLookUp {value; _} -> print_map_lookup value
 | MapInj inj           -> print_injection "map" print_binding inj

src/ligo/ligo-parser/AST.mli

@@ -329,7 +329,7 @@ and instruction =
 
 and single_instr =
   Cond        of conditional reg
-| Case        of case_instr reg
+| Case_instr  of case_instr reg
 | Assign      of assignment reg
 | Loop        of loop
 | ProcCall    of fun_call
@@ -414,18 +414,35 @@ and case_instr = {
   expr      : expr;
   kwd_of    : kwd_of;
   lead_vbar : vbar option;
-  cases     : cases;
+  cases_instr     : cases_instr;
   kwd_end   : kwd_end
 }
 
-and cases = (case reg, vbar) nsepseq reg
+and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
 
-and case = {
+and case_clause_instr = {
   pattern : pattern;
   arrow   : arrow;
   instr   : instruction
 }
 
+and case_expr = {
+  kwd_case  : kwd_case;
+  expr      : expr;
+  kwd_of    : kwd_of;
+  lead_vbar : vbar option;
+  cases_expr: cases_expr;
+  kwd_end   : kwd_end
+}
+
+and cases_expr = (case_clause_expr reg, vbar) nsepseq reg
+
+and case_clause_expr = {
+  pattern : pattern;
+  arrow   : arrow;
+  expr    : expr;
+}
+
 and assignment = {
   lhs    : lhs;
   assign : assign;
@@ -482,7 +499,8 @@ and for_collect = {
 (* Expressions *)
 
 and expr =
-  ELogic  of logic_expr
+  ECase   of case_expr reg
+| ELogic  of logic_expr
 | EArith  of arith_expr
 | EString of string_expr
 | EList   of list_expr

src/ligo/ligo-parser/Parser.mly

@@ -483,7 +483,7 @@ instruction:
 
 single_instr:
   conditional  {        Cond $1 }
-| case_instr   {        Case $1 }
+| case_instr   {        Case_instr $1 }
 | assignment   {      Assign $1 }
 | loop         {        Loop $1 }
 | proc_call    {    ProcCall $1 }
@@ -672,23 +672,23 @@ if_clause:
    ClauseBlock {value; region}}
 
 case_instr:
-  Case expr Of option(VBAR) cases End {
+  Case expr Of option(VBAR) cases_instr End {
     let region = cover $1 $6 in
     let value = {
       kwd_case  = $1;
       expr      = $2;
       kwd_of    = $3;
       lead_vbar = $4;
-      cases     = $5;
+      cases_instr = $5;
       kwd_end   = $6}
     in {region; value}}
 
-cases:
+cases_instr:
-  nsepseq(case,VBAR) {
+  nsepseq(case_clause_instr,VBAR) {
     let region = nsepseq_to_region (fun x -> x.region) $1
     in {region; value = $1}}
 
-case:
+case_clause_instr:
   pattern ARROW instruction {
     let region = cover (pattern_to_region $1) (instr_to_region $3)
     and value  = {pattern = $1; arrow = $2; instr = $3}
@@ -764,7 +764,34 @@ interactive_expr:
   expr EOF { $1 }
 
 expr:
-  expr Or conj_expr {
+  case_expr { $1 }
+| disj_expr { $1 }
+
+case_expr:
+  Case expr Of option(VBAR) cases_expr End {
+    let region = cover $1 $6 in
+    let value = {
+      kwd_case  = $1;
+      expr      = $2;
+      kwd_of    = $3;
+      lead_vbar = $4;
+      cases_expr = $5;
+      kwd_end   = $6}
+    in ECase {region; value}}
+
+cases_expr:
+  nsepseq(case_clause_expr,VBAR) {
+    let region = nsepseq_to_region (fun x -> x.region) $1
+    in {region; value = $1}}
+
+case_clause_expr:
+  pattern ARROW expr {
+    let region = cover (pattern_to_region $1) (expr_to_region $3)
+    and value  = {pattern = $1; arrow = $2; expr = $3}
+    in {region; value}}
+
+disj_expr:
+  disj_expr Or conj_expr {
     let start  = expr_to_region $1
     and stop   = expr_to_region $3 in
     let region = cover start stop

src/ligo/mini_c.ml

@@ -70,6 +70,7 @@ and expression' =
   | Var of var_name
   | Empty_map of (type_value * type_value)
   | Make_None of type_value
+  | E_Cond of expression * expression * expression
 
 and expression = expression' * type_value * environment (* Environment in which the expressions are evaluated *)
 
@@ -77,7 +78,7 @@ and assignment = var_name * expression
 
 and statement' =
   | Assignment of assignment
-  | Cond of expression * block * block
+  | I_Cond of expression * block * block
   | If_None of expression * block * (var_name * block)
   | While of expression * block
 
@@ -179,6 +180,7 @@ module PP = struct
     | Function_expression c -> function_ ppf c
     | Empty_map _ -> fprintf ppf "map[]"
     | Make_None _ -> fprintf ppf "none"
+    | E_Cond (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
 
   and function_ ppf ({binder ; input ; output ; body ; result}:anon_function_content) =
         fprintf ppf "fun (%s:%a) : %a %a return %a"
@@ -192,7 +194,7 @@ module PP = struct
 
   and statement ppf ((s, _) : statement) = match s with
     | Assignment ass -> assignment ppf ass
-    | Cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e
+    | I_Cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e
     | If_None (expr, none, (name, some)) -> fprintf ppf "if (%a) %a %s.%a" expression expr block none name block some
     | While (e, b) -> fprintf ppf "while (%a) %a" expression e block b
 
@@ -823,7 +825,18 @@ module Translate_program = struct
                 ] in
               ok code
           | _ -> simple_fail "expected function code"
-        ) in
+        )
+      | E_Cond (c, a, b) -> (
+          let%bind c' = translate_expression c in
+          let%bind a' = translate_expression a in
+          let%bind b' = translate_expression b in
+          let%bind code = ok (seq [
+              c' ; i_unpair ;
+              i_if a' b' ;
+            ]) in
+          ok code
+        )
+    in
 
     let%bind () =
       let%bind (Ex_ty schema_ty) = Environment.to_ty env in
@@ -874,7 +887,7 @@ module Translate_program = struct
             add ;
           ];
         ])
-    | Cond (expr, a, b) ->
+    | I_Cond (expr, a, b) ->
       let%bind expr = translate_expression expr in
       let%bind a = translate_regular_block a in
       let%bind b = translate_regular_block b in
@@ -1195,7 +1208,7 @@ module Combinators = struct
 
   let statement s' e : statement =
     match s' with
-    | Cond _ -> s', id_environment_wrap e
+    | I_Cond _ -> s', id_environment_wrap e
     | If_None _ -> s', id_environment_wrap e
     | While _ -> s', id_environment_wrap e
     | Assignment (name, (_, t, _)) -> s', environment_wrap e (Environment.add (name, t) e)

src/ligo/simplify.ml

@@ -160,6 +160,18 @@ let rec simpl_expression (t:Raw.expr) : ae result =
   | ELogic l -> simpl_logic_expression l
   | EList _ -> simple_fail "list: not supported yet"
   | ESet _ -> simple_fail "set: not supported yet"
+  | ECase c ->
+      let%bind e = simpl_expression c.value.expr in
+      let%bind lst =
+        let aux (x:Raw.case_clause_expr) =
+          let%bind expr = simpl_expression x.expr in
+          ok (x.pattern, expr) in
+        bind_list
+        @@ List.map aux
+        @@ List.map get_value
+        @@ npseq_to_list c.value.cases_expr.value in
+      let%bind cases = simpl_cases lst in
+      ok @@ ae @@ Matching_expr (e, cases)
   | EMap (MapInj mi) ->
       let%bind lst =
         let lst = List.map get_value @@ pseq_to_list mi.value.elements in
@@ -369,7 +381,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
       let%bind match_false = match c.ifnot with
         | ClauseInstr i -> let%bind i = simpl_instruction i in ok [i]
         | ClauseBlock b -> simpl_statements @@ fst b.value.inside in
-      ok @@ Matching (expr, (Match_bool {match_true; match_false}))
+      ok @@ Matching_instr (expr, (Match_bool {match_true; match_false}))
   | Assign a ->
       let a = a.value in
       let%bind name = match a.lhs with
@@ -381,18 +393,18 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
         | _ -> simple_fail "no weird assignments yet"
       in
       ok @@ Assignment {name ; annotated_expression}
-  | Case c ->
+  | Case_instr c ->
       let c = c.value in
       let%bind expr = simpl_expression c.expr in
       let%bind cases =
-        let aux (x : Raw.case Raw.reg) =
+        let aux (x : Raw.case_clause_instr Raw.reg) =
           let%bind i = simpl_instruction_block x.value.instr in
           ok (x.value.pattern, i) in
         bind_list
         @@ List.map aux
-        @@ npseq_to_list c.cases.value in
+        @@ npseq_to_list c.cases_instr.value in
       let%bind m = simpl_cases cases in
-      ok @@ Matching (expr, m)
+      ok @@ Matching_instr (expr, m)
   | RecordPatch r ->
       let r = r.value in
       let%bind record = match r.path with
@@ -409,7 +421,7 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
   | MapRemove _ -> simple_fail "no map remove yet"
   | SetRemove _ -> simple_fail "no set remove yet"
 
-and simpl_cases : (Raw.pattern * block) list -> matching result = fun t ->
+and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t ->
   let open Raw in
   let get_var (t:Raw.pattern) = match t with
     | PVar v -> ok v.value

src/ligo/test/integration_tests.ml

@@ -239,6 +239,21 @@ let matching () : unit result =
       @@ [0 ; 2 ; 42 ; 163 ; -1] in
     ok ()
   in
+  let%bind _expr_bool =
+    let aux n =
+      let open AST_Typed.Combinators in
+      let input = a_int n in
+      let%bind result = easy_run_typed "match_expr_bool" program input in
+      let%bind result' =
+        trace (simple_error "bad result") @@
+        get_a_int result in
+      Assert.assert_equal_int (if n = 2 then 42 else 0) result'
+    in
+    let%bind _ = bind_list
+      @@ List.map aux
+      @@ [0 ; 2 ; 42 ; 163 ; -1] in
+    ok ()
+  in
   let%bind _option =
     let aux n =
       let open AST_Typed.Combinators in

src/ligo/transpiler.ml

@@ -74,14 +74,14 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement op
       let%bind (_, t, _) as expression = translate_annotated_expression env annotated_expression in
       let env' = Environment.add (name, t) env in
       return ~env' (Assignment (name, expression))
-  | Matching (expr, m) -> (
+  | Matching_instr (expr, m) -> (
       let%bind expr' = translate_annotated_expression env expr in
       let env' = Environment.extend env in
       match m with
       | Match_bool {match_true ; match_false} -> (
           let%bind true_branch = translate_block env' match_true in
           let%bind false_branch = translate_block env' match_false in
-          return (Cond (expr', true_branch, false_branch))
+          return (I_Cond (expr', true_branch, false_branch))
         )
       | Match_option {match_none ; match_some = ((name, t), sm)} -> (
           let%bind none_branch = translate_block env' match_none in
@@ -235,6 +235,15 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
   | LookUp dsi ->
       let%bind (ds', i') = bind_map_pair f dsi in
       return (Predicate ("GET", [i' ; ds']), tv)
+  | Matching_expr (expr, m) -> (
+      let%bind expr' = translate_annotated_expression env expr in
+      match m with
+      | AST.Match_bool {match_true ; match_false} ->
+          let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in
+          return (E_Cond (expr', t, f), tv)
+      | AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) ->
+          simple_fail "only match bool exprs are translated yet"
+    )
 
 and translate_lambda_shallow env l tv =
   let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in

src/ligo/typer.ml

@@ -162,39 +162,40 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
           let e' = Environment.add e name annotated_expression.type_annotation in
           ok (e', O.Assignment {name;annotated_expression})
     )
-  | Matching (ex, m) ->
+  | Matching_instr (ex, m) ->
       let%bind ex' = type_annotated_expression e ex in
-      let%bind m' = type_match e ex'.type_annotation m in
+      let%bind m' = type_match type_block e ex'.type_annotation m in
-      ok (e, O.Matching (ex', m'))
+      ok (e, O.Matching_instr (ex', m'))
   | Record_patch _ -> simple_fail "no record_patch yet"
 
-and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching result = function
+and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result =
+  fun f e t i -> match i with
   | Match_bool {match_true ; match_false} ->
       let%bind _ =
         trace_strong (simple_error "Matching bool on not-a-bool")
         @@ get_t_bool t in
-      let%bind match_true = type_block e match_true in
+      let%bind match_true = f e match_true in
-      let%bind match_false = type_block e match_false in
+      let%bind match_false = f e match_false in
       ok (O.Match_bool {match_true ; match_false})
   | Match_option {match_none ; match_some} ->
       let%bind t_opt =
         trace_strong (simple_error "Matching option on not-an-option")
         @@ get_t_option t in
-      let%bind match_none = type_block e match_none in
+      let%bind match_none = f e match_none in
       let (n, b) = match_some in
       let n' = n, t_opt in
       let e' = Environment.add e n t_opt in
-      let%bind b' = type_block e' b in
+      let%bind b' = f e' b in
       ok (O.Match_option {match_none ; match_some = (n', b')})
   | Match_list {match_nil ; match_cons} ->
       let%bind t_list =
         trace_strong (simple_error "Matching list on not-an-list")
         @@ get_t_list t in
-      let%bind match_nil = type_block e match_nil in
+      let%bind match_nil = f e match_nil in
       let (hd, tl, b) = match_cons in
       let e' = Environment.add e hd t_list in
       let e' = Environment.add e' tl t in
-      let%bind b' = type_block e' b in
+      let%bind b' = f e' b in
       ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
   | Match_tuple (lst, b) ->
       let%bind t_tuple =
@@ -205,7 +206,7 @@ and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching resul
         @@ (fun () -> List.combine lst t_tuple) in
       let aux prev (name, tv) = Environment.add prev name tv in
       let e' = List.fold_left aux e lst' in
-      let%bind b' = type_block e' b in
+      let%bind b' = f e' b in
       ok (O.Match_tuple (lst, b'))
 
 and evaluate_type (e:environment) (t:I.type_expression) : O.type_value result =
@@ -383,7 +384,17 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
       let dst_opt = make_t_option dst in
       let%bind type_annotation = check dst_opt in
       ok O.{expression = LookUp (ds, ind) ; type_annotation}
-
+  (* Advanced *)
+  | Matching_expr (ex, m) -> (
+      let%bind ex' = type_annotated_expression e ex in
+      let%bind m' = type_match type_annotated_expression e ex'.type_annotation m in
+      let%bind type_annotation = match m' with
+        | Match_bool {match_true ; match_false} ->
+            let%bind _ = O.assert_type_value_eq (match_true.type_annotation, match_false.type_annotation) in
+            ok match_true.type_annotation
+        | _ -> simple_fail "can only type match_bool expressions yet" in
+      ok O.{expression = Matching_expr (ex', m') ; type_annotation}
+    )
 
 and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result =
   (* Constant poorman's polymorphism *)
@@ -476,6 +487,10 @@ let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_ex
   | LookUp dsi ->
       let%bind dsi' = bind_map_pair untype_annotated_expression dsi in
       return (LookUp dsi')
+  | Matching_expr (ae, m) ->
+      let%bind ae' = untype_annotated_expression ae in
+      let%bind m' = untype_matching untype_annotated_expression m in
+      return (Matching_expr (ae', m'))
 
 and untype_block (b:O.block) : (I.block) result =
   bind_list @@ List.map untype_instruction b
@@ -494,28 +509,28 @@ and untype_instruction (i:O.instruction) : (I.instruction) result =
   | Assignment a ->
       let%bind annotated_expression = untype_annotated_expression a.annotated_expression in
       ok @@ Assignment {name = a.name ; annotated_expression}
-  | Matching (e, m) ->
+  | Matching_instr (e, m) ->
       let%bind e' = untype_annotated_expression e in
-      let%bind m' = untype_matching m in
+      let%bind m' = untype_matching untype_block m in
-      ok @@ Matching (e', m')
+      ok @@ Matching_instr (e', m')
 
-and untype_matching (m:O.matching) : (I.matching) result =
+and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m ->
   let open I in
   match m with
   | Match_bool {match_true ; match_false} ->
-      let%bind match_true = untype_block match_true in
+      let%bind match_true = f match_true in
-      let%bind match_false = untype_block match_false in
+      let%bind match_false = f match_false in
       ok @@ Match_bool {match_true ; match_false}
   | Match_tuple (lst, b) ->
-      let%bind b = untype_block b in
+      let%bind b = f b in
       ok @@ Match_tuple (lst, b)
   | Match_option {match_none ; match_some = (v, some)} ->
-      let%bind match_none = untype_block match_none in
+      let%bind match_none = f match_none in
-      let%bind some = untype_block some in
+      let%bind some = f some in
       let match_some = fst v, some in
       ok @@ Match_option {match_none ; match_some}
   | Match_list {match_nil ; match_cons = (hd, tl, cons)} ->
-      let%bind match_nil = untype_block match_nil in
+      let%bind match_nil = f match_nil in
-      let%bind cons = untype_block cons in
+      let%bind cons = f cons in
       let match_cons = hd, tl, cons in
       ok @@ Match_list {match_nil ; match_cons}