Factorised the "case" constructs into one.

src/ligo/ligo-parser/.gitignore

@@ -6,3 +6,7 @@ _build/*
 *.install
 /Version.ml
 /dune-project
+/Parser.mli
+/Parser.ml
+/Lexer.ml
+/LexToken.ml

src/ligo/ligo-parser/AST.ml

@@ -338,7 +338,7 @@ and instruction =
 
 and single_instr =
   Cond        of conditional reg
-| Case_instr  of case_instr reg
+| CaseInstr   of instruction case reg
 | Assign      of assignment reg
 | Loop        of loop
 | ProcCall    of fun_call
@@ -418,38 +418,19 @@ and set_membership = {
   element      : expr
 }
 
-and case_instr = {
+and 'a case = {
   kwd_case   : kwd_case;
   expr       : expr;
   kwd_of     : kwd_of;
   lead_vbar  : vbar option;
-  cases_instr : cases_instr;
+  cases      : ('a case_clause reg, vbar) nsepseq reg;
   kwd_end    : kwd_end
 }
 
-and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
+and 'a case_clause = {
-
-and case_clause_instr = {
   pattern : pattern;
   arrow   : arrow;
-  instr   : instruction
+  rhs     : 'a
-}
-
-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 = {
@@ -508,7 +489,7 @@ and for_collect = {
 (* Expressions *)
 
 and expr =
-| ECase   of case_expr reg
+| ECase   of expr case reg
 | ELogic  of logic_expr
 | EArith  of arith_expr
 | EString of string_expr
@@ -773,7 +754,7 @@ let path_to_region = function
 
 let instr_to_region = function
   Single Cond                {region; _}
-| Single Case_instr          {region; _}
+| Single CaseInstr           {region; _}
 | Single Assign              {region; _}
 | Single Loop While          {region; _}
 | Single Loop For ForInt     {region; _}
@@ -1092,7 +1073,7 @@ and print_instruction = function
 
 and print_single_instr = function
   Cond        {value; _} -> print_conditional value
-| Case_instr  {value; _} -> print_case_instr value
+| CaseInstr   {value; _} -> print_case_instr value
 | Assign      assign     -> print_assignment assign
 | Loop        loop       -> print_loop loop
 | ProcCall    fun_call   -> print_fun_call fun_call
@@ -1129,14 +1110,14 @@ and print_if_clause = function
     print_terminator terminator;
     print_token rbrace "}"
 
-and print_case_instr (node : case_instr) =
+and print_case_instr (node : instruction case) =
   let {kwd_case; expr; kwd_of;
-       lead_vbar; cases_instr; kwd_end} = node in
+       lead_vbar; cases; kwd_end} = node in
   print_token kwd_case "case";
   print_expr  expr;
   print_token kwd_of "of";
   print_token_opt lead_vbar "|";
-  print_cases_instr cases_instr;
+  print_cases_instr cases;
   print_token kwd_end "end"
 
 and print_token_opt = function
@@ -1147,10 +1128,10 @@ and print_cases_instr {value; _} =
   print_nsepseq "|" print_case_clause_instr value
 
 and print_case_clause_instr {value; _} =
-  let {pattern; arrow; instr} = value in
+  let {pattern; arrow; rhs} = value in
   print_pattern pattern;
   print_token arrow "->";
-  print_instruction instr
+  print_instruction rhs
 
 and print_assignment {value; _} =
   let {lhs; assign; rhs} = value in
@@ -1240,24 +1221,24 @@ and print_expr = function
 | ETuple  e -> print_tuple_expr e
 | EPar    e -> print_par_expr e
 
-and print_case_expr (node : case_expr) =
+and print_case_expr (node : expr case) =
   let {kwd_case; expr; kwd_of;
-       lead_vbar; cases_expr; kwd_end} = node in
+       lead_vbar; cases; 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_cases_expr cases;
   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
+  let {pattern; arrow; rhs} = value in
   print_pattern pattern;
   print_token arrow "->";
-  print_expr expr
+  print_expr rhs
 
 and print_map_expr = function
   MapLookUp {value; _} -> print_map_lookup value

src/ligo/ligo-parser/AST.mli

@@ -322,7 +322,7 @@ and instruction =
 
 and single_instr =
   Cond        of conditional reg
-| Case_instr  of case_instr reg
+| CaseInstr   of instruction case reg
 | Assign      of assignment reg
 | Loop        of loop
 | ProcCall    of fun_call
@@ -402,38 +402,19 @@ and set_membership = {
   element      : expr
 }
 
-and case_instr = {
+and 'a case = {
   kwd_case  : kwd_case;
   expr      : expr;
   kwd_of    : kwd_of;
   lead_vbar : vbar option;
-  cases_instr     : cases_instr;
+  cases     : ('a case_clause reg, vbar) nsepseq reg;
   kwd_end   : kwd_end
 }
 
-and cases_instr = (case_clause_instr reg, vbar) nsepseq reg
+and 'a case_clause = {
-
-and case_clause_instr = {
   pattern : pattern;
   arrow   : arrow;
-  instr   : instruction
+  rhs     : 'a
-}
-
-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 = {
@@ -492,7 +473,7 @@ and for_collect = {
 (* Expressions *)
 
 and expr =
-  ECase   of case_expr reg
+  ECase   of expr case reg
 | ELogic  of logic_expr
 | EArith  of arith_expr
 | EString of string_expr

src/ligo/ligo-parser/Parser.mly

@@ -21,9 +21,9 @@ open AST
 
 (* RULES *)
 
-(* The rule [series(Item,TERM)] parses a list of [Item] separated by
+(* The rule [series(Item,TERM)] parses a non-empty list of [Item]
-   semicolons and optionally terminated by a semicolon, then the
+   separated by semicolons and optionally terminated by a semicolon,
-   terminal TERM. *)
+   then the terminal TERM. *)
 
 series(Item,TERM):
   Item after_item(Item,TERM) { $1,$2 }
@@ -492,7 +492,7 @@ instruction:
 
 single_instr:
   conditional  {        Cond $1 }
-| case_instr   {        Case_instr $1 }
+| case_instr   {   CaseInstr $1 }
 | assignment   {      Assign $1 }
 | loop         {        Loop $1 }
 | proc_call    {    ProcCall $1 }
@@ -688,9 +688,16 @@ case_instr:
       expr      = $2;
       kwd_of    = $3;
       lead_vbar = $4;
-      cases_instr = $5;
+      cases     = $5;
       kwd_end   = $6}
     in {region; value}}
+(*| Case expr LBRACKET option(VBAR) case_instr RBRACKET {
+    let region = cover $1 $6 in
+    let value  = {
+      k
+      }
+  }
+ *)
 
 cases_instr:
   nsepseq(case_clause_instr,VBAR) {
@@ -699,8 +706,9 @@ cases_instr:
 
 case_clause_instr:
   pattern ARROW instruction {
-    let region = cover (pattern_to_region $1) (instr_to_region $3)
+    let start  = pattern_to_region $1 in
-    and value  = {pattern = $1; arrow = $2; instr = $3}
+    let region = cover start (instr_to_region $3)
+    and value  = {pattern=$1; arrow=$2; rhs=$3}
     in {region; value}}
 
 assignment:
@@ -779,12 +787,12 @@ expr:
 case_expr:
   Case expr Of option(VBAR) cases_expr End {
     let region = cover $1 $6 in
-    let value = {
+    let value : expr case = {
       kwd_case  = $1;
       expr      = $2;
       kwd_of    = $3;
       lead_vbar = $4;
-      cases_expr = $5;
+      cases     = $5;
       kwd_end   = $6}
     in ECase {region; value}}
 
@@ -795,8 +803,9 @@ cases_expr:
 
 case_clause_expr:
   pattern ARROW expr {
-    let region = cover (pattern_to_region $1) (expr_to_region $3)
+    let start  = pattern_to_region $1 in
-    and value  = {pattern = $1; arrow = $2; expr = $3}
+    let region = cover start (expr_to_region $3)
+    and value  = {pattern=$1; arrow=$2; rhs=$3}
     in {region; value}}
 
 disj_expr:

src/ligo/simplify.ml

@@ -163,13 +163,13 @@ let rec simpl_expression (t:Raw.expr) : ae result =
   | ECase c ->
       let%bind e = simpl_expression c.value.expr in
       let%bind lst =
-        let aux (x:Raw.case_clause_expr) =
+        let aux (x : Raw.expr Raw.case_clause) =
-          let%bind expr = simpl_expression x.expr in
+          let%bind expr = simpl_expression x.rhs in
           ok (x.pattern, expr) in
         bind_list
         @@ List.map aux
         @@ List.map get_value
-        @@ npseq_to_list c.value.cases_expr.value in
+        @@ npseq_to_list c.value.cases.value in
       let%bind cases = simpl_cases lst in
       ok @@ ae @@ E_matching (e, cases)
   | EMap (MapInj mi) ->
@@ -393,16 +393,16 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t ->
         | _ -> simple_fail "no weird assignments yet"
       in
       ok @@ I_assignment {name ; annotated_expression}
-  | Case_instr c ->
+  | CaseInstr c ->
       let c = c.value in
       let%bind expr = simpl_expression c.expr in
       let%bind cases =
-        let aux (x : Raw.case_clause_instr Raw.reg) =
+        let aux (x : Raw.instruction Raw.case_clause Raw.reg) =
-          let%bind i = simpl_instruction_block x.value.instr in
+          let%bind i = simpl_instruction_block x.value.rhs in
           ok (x.value.pattern, i) in
         bind_list
         @@ List.map aux
-        @@ npseq_to_list c.cases_instr.value in
+        @@ npseq_to_list c.cases.value in
       let%bind m = simpl_cases cases in
       ok @@ I_matching (expr, m)
   | RecordPatch r ->