I added record creation (injection), field selection (projection)

and functional update (copy).

The only creative piece of concrete syntax is that of the
expression for functional updates:

copy foo with record field = value end

where "copy", "with", "record" and "end" are keywords.

AST.ml

@@ -41,6 +41,7 @@ let sepseq_to_region to_region = function
 
 type kwd_begin      = Region.t
 type kwd_const      = Region.t
+type kwd_copy       = Region.t
 type kwd_down       = Region.t
 type kwd_else       = Region.t
 type kwd_end        = Region.t
@@ -221,7 +222,7 @@ and record_type = {
 and field_decls = (field_decl reg, semi) nsepseq
 
 and field_decl = {
-  var        : variable;
+  field_name : field_name;
   colon      : colon;
   field_type : type_expr
 }
@@ -311,7 +312,7 @@ and var_decl = {
   terminator : semi option
 }
 
-and instructions = (instruction, semi) nsepseq reg
+and instructions = (instruction, semi) nsepseq
 
 and instruction =
   Single of single_instr
@@ -405,6 +406,7 @@ and expr =
 | ListExpr   of list_expr
 | SetExpr    of set_expr
 | ConstrExpr of constr_expr
+| RecordExpr of record_expr
 | Var        of Lexer.lexeme reg
 | FunCall    of fun_call
 | Bytes      of (Lexer.lexeme * MBytes.t) reg
@@ -470,6 +472,37 @@ and constr_expr =
 | NoneExpr  of none_expr reg
 | ConstrApp of (constr * arguments) reg
 
+and record_expr =
+  RecordInj  of record_injection reg
+| RecordProj of record_projection reg
+| RecordCopy of record_copy reg
+
+and record_injection = {
+  opening    : kwd_record;
+  fields     : (field_ass reg, semi) nsepseq;
+  terminator : semi option;
+  close      : kwd_end
+}
+
+and field_ass = {
+  field_name : field_name;
+  equal      : equal;
+  field_expr : expr
+}
+
+and record_projection = {
+  record_name : variable;
+  selector    : dot;
+  field_name  : field_name
+}
+
+and record_copy = {
+  kwd_copy    : kwd_copy;
+  record_name : variable;
+  kwd_with    : kwd_with;
+  delta       : record_injection reg
+}
+
 and tuple = (expr, comma) nsepseq par reg
 
 and empty_list = typed_empty_list par
@@ -548,6 +581,7 @@ let rec expr_to_region = function
 | ListExpr   e -> list_expr_to_region e
 | SetExpr    e -> set_expr_to_region e
 | ConstrExpr e -> constr_expr_to_region e
+| RecordExpr e -> record_expr_to_region e
 | Var       {region; _}
 | FunCall   {region; _}
 | Bytes     {region; _}
@@ -602,6 +636,11 @@ and constr_expr_to_region = function
 | ConstrApp {region; _}
 | SomeApp   {region; _} -> region
 
+and record_expr_to_region = function
+  RecordInj  {region; _}
+| RecordProj {region; _}
+| RecordCopy {region; _} -> region
+
 let instr_to_region = function
   Single Cond                {region; _}
 | Single Match               {region; _}
@@ -775,8 +814,8 @@ and print_field_decls sequence =
   print_nsepseq ";" print_field_decl sequence
 
 and print_field_decl {value; _} =
-  let {var; colon; field_type} = value in
+  let {field_name; colon; field_type} = value in
-  print_var       var;
+  print_var       field_name;
   print_token     colon ":";
   print_type_expr field_type
 
@@ -879,8 +918,8 @@ and print_var_decl {value; _} =
   print_expr       init;
   print_terminator terminator
 
-and print_instructions {value; _} =
+and print_instructions sequence =
-  print_nsepseq ";" print_instruction value
+  print_nsepseq ";" print_instruction sequence
 
 and print_instruction = function
   Single instr -> print_single_instr instr
@@ -995,6 +1034,7 @@ and print_expr = function
 | ListExpr e   -> print_list_expr e
 | SetExpr e    -> print_set_expr e
 | ConstrExpr e -> print_constr_expr e
+| RecordExpr e -> print_record_expr e
 | Var var      -> print_var var
 | FunCall e    -> print_fun_call e
 | Bytes b      -> print_bytes b
@@ -1066,6 +1106,37 @@ and print_constr_expr = function
 | NoneExpr e  -> print_none_expr e
 | ConstrApp e -> print_constr_app e
 
+and print_record_expr = function
+  RecordInj  e -> print_record_injection e
+| RecordProj e -> print_record_projection e
+| RecordCopy e -> print_record_copy e
+
+and print_record_injection {value; _} =
+  let {opening; fields; terminator; close} = value in
+  print_token opening "record";
+  print_nsepseq ";" print_field_ass fields;
+  print_terminator terminator;
+  print_token close "end"
+
+and print_field_ass {value; _} =
+  let {field_name; equal; field_expr} = value in
+  print_var field_name;
+  print_token equal "=";
+  print_expr field_expr
+
+and print_record_projection {value; _} =
+  let {record_name; selector; field_name} = value in
+  print_var record_name;
+  print_token selector ".";
+  print_var field_name
+
+and print_record_copy {value; _} =
+  let {kwd_copy; record_name; kwd_with; delta} = value in
+  print_token kwd_copy "copy";
+  print_var record_name;
+  print_token kwd_with "with";
+  print_record_injection delta
+
 and print_tuple {value; _} =
   let {lpar; inside; rpar} = value in
   print_token lpar "(";

AST.mli

@@ -25,6 +25,7 @@ val sepseq_to_region  : ('a -> Region.t) -> ('a,'sep) sepseq -> Region.t
 
 type kwd_begin      = Region.t
 type kwd_const      = Region.t
+type kwd_copy       = Region.t
 type kwd_down       = Region.t
 type kwd_else       = Region.t
 type kwd_end        = Region.t
@@ -205,7 +206,7 @@ and record_type = {
 and field_decls = (field_decl reg, semi) nsepseq
 
 and field_decl = {
-  var        : variable;
+  field_name : field_name;
   colon      : colon;
   field_type : type_expr
 }
@@ -295,7 +296,7 @@ and var_decl = {
   terminator : semi option
 }
 
-and instructions = (instruction, semi) nsepseq reg
+and instructions = (instruction, semi) nsepseq
 
 and instruction =
   Single of single_instr
@@ -389,6 +390,7 @@ and expr =
 | ListExpr   of list_expr
 | SetExpr    of set_expr
 | ConstrExpr of constr_expr
+| RecordExpr of record_expr
 | Var        of Lexer.lexeme reg
 | FunCall    of fun_call
 | Bytes      of (Lexer.lexeme * MBytes.t) reg
@@ -454,6 +456,37 @@ and constr_expr =
 | NoneExpr  of none_expr reg
 | ConstrApp of (constr * arguments) reg
 
+and record_expr =
+  RecordInj  of record_injection reg
+| RecordProj of record_projection reg
+| RecordCopy of record_copy reg
+
+and record_injection = {
+  opening    : kwd_record;
+  fields     : (field_ass reg, semi) nsepseq;
+  terminator : semi option;
+  close      : kwd_end
+}
+
+and field_ass = {
+  field_name : field_name;
+  equal      : equal;
+  field_expr : expr
+}
+
+and record_projection = {
+  record_name : variable;
+  selector    : dot;
+  field_name  : field_name
+}
+
+and record_copy = {
+  kwd_copy    : kwd_copy;
+  record_name : variable;
+  kwd_with    : kwd_with;
+  delta       : record_injection reg
+}
+
 and tuple = (expr, comma) nsepseq par reg
 
 and empty_list = typed_empty_list par

LexToken.mli

@@ -69,6 +69,7 @@ type t =
 
 | Begin      of Region.t  (* "begin"      *)
 | Const      of Region.t  (* "const"      *)
+| Copy       of Region.t  (* "copy"       *)
 | Down       of Region.t  (* "down"       *)
 | Fail       of Region.t  (* "fail"       *)
 | If         of Region.t  (* "if"         *)

LexToken.mll

@@ -68,6 +68,7 @@ type t =
 
 | Begin      of Region.t
 | Const      of Region.t
+| Copy       of Region.t
 | Down       of Region.t
 | Fail       of Region.t
 | If         of Region.t
@@ -187,6 +188,7 @@ let proj_token = function
 
 | Begin      region -> region, "Begin"
 | Const      region -> region, "Const"
+| Copy       region -> region, "Copy"
 | Down       region -> region, "Down"
 | Fail       region -> region, "Fail"
 | If         region -> region, "If"
@@ -271,6 +273,7 @@ let to_lexeme = function
 
 | Begin      _ -> "begin"
 | Const      _ -> "const"
+| Copy       _ -> "copy"
 | Down       _ -> "down"
 | Fail       _ -> "fail"
 | If         _ -> "if"
@@ -323,6 +326,7 @@ let to_region token = proj_token token |> fst
 let keywords = [
   (fun reg -> Begin      reg);
   (fun reg -> Const      reg);
+  (fun reg -> Copy       reg);
   (fun reg -> Down       reg);
   (fun reg -> Fail       reg);
   (fun reg -> If         reg);
@@ -545,8 +549,9 @@ let is_ident = function
 |       _ -> false
 
 let is_kwd = function
-| Begin      _
+  Begin      _
 | Const      _
+| Copy       _
 | Down       _
 | Fail       _
 | If         _

ParToken.mly

@@ -46,6 +46,7 @@
 
 %token <Region.t> Begin       (* "begin"      *)
 %token <Region.t> Const       (* "const"      *)
+%token <Region.t> Copy        (* "copy"       *)
 %token <Region.t> Down        (* "down"       *)
 %token <Region.t> Fail        (* "fail"       *)
 %token <Region.t> If          (* "if"         *)

Parser.mly

@@ -97,6 +97,7 @@ sepseq(X,Sep):
 %inline type_name   : Ident { $1 }
 %inline fun_name    : Ident { $1 }
 %inline field_name  : Ident { $1 }
+%inline record_name : Ident { $1 }
 %inline map_name    : Ident { $1 }
 
 (* Main *)
@@ -117,8 +118,8 @@ storage_decl:
   Storage var COLON type_expr option(SEMI) {
     let stop =
       match $5 with
-               None -> type_expr_to_region $4
+        Some region -> region
-      | Some region -> region in
+      |        None -> type_expr_to_region $4 in
     let region = cover $1 stop in
     let value = {
       kwd_storage = $1;
@@ -133,8 +134,8 @@ operations_decl:
   Operations var COLON type_expr option(SEMI) {
     let stop =
       match $5 with
-              None -> type_expr_to_region $4
+        Some region -> region
-     | Some region -> region in
+      |        None -> type_expr_to_region $4 in
     let region = cover $1 stop in
     let value = {
       kwd_operations = $1;
@@ -151,8 +152,8 @@ type_decl:
   Type type_name Is type_expr option(SEMI) {
     let stop =
       match $5 with
-        None -> type_expr_to_region $4
+        Some region -> region
-      | Some region -> region in
+      |        None -> type_expr_to_region $4 in
     let region = cover $1 stop in
     let value = {
       kwd_type   = $1;
@@ -197,10 +198,7 @@ sum_type:
 variant:
   Constr Of cartesian {
     let region = cover $1.region $3.region
-    and value = {
+    and value = {constr = $1; kwd_of = $2; product = $3}
-      constr  = $1;
-      kwd_of  = $2;
-      product = $3}
     in {region; value}
   }
 
@@ -210,10 +208,7 @@ record_type:
   End
   {
    let region = cover $1 $3
-   and value = {
+   and value  = {kwd_record = $1; fields = $2; kwd_end = $3}
-     kwd_record = $1;
-     fields     = $2;
-     kwd_end    = $3}
    in {region; value}
   }
 
@@ -221,10 +216,7 @@ field_decl:
   field_name COLON type_expr {
     let stop   = type_expr_to_region $3 in
     let region = cover $1.region stop
-    and value  = {
+    and value  = {field_name = $1; colon = $2; field_type = $3}
-      var        = $1;
-      colon      = $2;
-      field_type = $3}
     in {region; value}
   }
 
@@ -242,8 +234,8 @@ fun_decl:
   With expr option(SEMI) {
     let stop =
       match $11 with
-               None -> expr_to_region $10
+        Some region -> region
-      | Some region -> region in
+      |        None -> expr_to_region $10 in
     let region = cover $1 stop in
     let value = {
       kwd_function = $1;
@@ -267,8 +259,8 @@ proc_decl:
     {
      let stop =
        match $7 with
-         None -> $6.region
+         Some region -> region
-       | Some region -> region in
+       |        None -> $6.region in
      let region = cover $1 stop in
      let value = {
        kwd_procedure = $1;
@@ -288,8 +280,8 @@ entry_decl:
     {
      let stop =
        match $7 with
-         None -> $6.region
+         Some region -> region
-       | Some region -> region in
+       |        None -> $6.region in
      let region = cover $1 stop in
      let value = {
        kwd_entrypoint = $1;
@@ -332,12 +324,10 @@ block:
     instruction after_instr
   {
    let instrs, terminator, close = $3 in
-   let region = cover $1 close in
+   let region = cover $1 close
-   let value = {
+   and value = {
      opening = $1;
-     instr       = (let value = $2, instrs in
+     instr   = $2, instrs;
-                    let region = nsepseq_to_region instr_to_region value
-                    in {value; region});
      terminator;
      close}
    in {region; value}
@@ -372,8 +362,8 @@ const_decl:
   Const var COLON type_expr EQUAL expr option(SEMI) {
     let stop =
       match $7 with
-        None -> expr_to_region $6
+        Some region -> region
-      | Some region -> region in
+      |        None -> expr_to_region $6 in
     let region = cover $1 stop in
     let value  = {
       kwd_const  = $1;
@@ -390,8 +380,8 @@ var_decl:
   Var var COLON type_expr ASS expr option(SEMI) {
     let stop =
       match $7 with
-               None -> expr_to_region $6
+        Some region -> region
-      | Some region -> region in
+      |        None -> expr_to_region $6 in
     let region = cover $1 stop in
     let value = {
       kwd_var    = $1;
@@ -420,9 +410,7 @@ single_instr:
 fail_instr:
   Fail expr {
     let region = cover $1 (expr_to_region $2)
-    and value  = {
+    and value  = {kwd_fail = $1; fail_expr = $2}
-      kwd_fail  = $1;
-      fail_expr = $2}
     in {region; value}}
 
 proc_call:
@@ -463,20 +451,14 @@ cases:
 case:
   pattern ARROW instruction {
     let region = cover (pattern_to_region $1) (instr_to_region $3)
-    and value  = {
+    and value  = {pattern = $1; arrow = $2; instr = $3}
-      pattern = $1;
-      arrow   = $2;
-      instr   = $3}
     in {region; value}
   }
 
 ass:
   var ASS expr {
     let region = cover $1.region (expr_to_region $3)
-    and value  = {
+    and value  = {var = $1; ass = $2; expr = $3}
-      var  = $1;
-      ass  = $2;
-      expr = $3}
     in {region; value}
   }
 
@@ -512,15 +494,13 @@ for_loop:
 
 | For var option(arrow_clause) In expr block {
     let region = cover $1 $6.region in
-    let value =
+    let value = {
-      {
       kwd_for = $1;
       var     = $2;
       bind_to = $3;
       kwd_in  = $4;
       expr    = $5;
-        block   = $6;
+      block   = $6}
-      }
     in For (ForCollect {region; value})
   }
 
@@ -701,14 +681,83 @@ core_expr:
   }
 | map_name DOT brackets(expr) {
     let region = cover $1.region $3.region in
-    let value =
+    let value  = {
-      {
       map_name = $1;
       selector = $2;
-        index    = $3;
+      index    = $3}
-      }
     in MapLookUp {region; value}
   }
+| record_expr { RecordExpr $1 }
+
+record_expr:
+  record_injection  { RecordInj  $1 }
+| record_projection { RecordProj $1 }
+| record_copy       { RecordCopy $1 }
+
+record_injection:
+  Record
+    field_assignment after_field
+  {
+   let fields, terminator, close = $3 in
+   let region = cover $1 close
+   and value = {
+     opening = $1;
+     fields  = $2, fields;
+     terminator;
+     close}
+   in {region; value}
+  }
+
+after_field:
+  SEMI field_or_end {
+    match $2 with
+      `Some (field, fields, term, close) ->
+        ($1, field)::fields, term, close
+    | `End close ->
+        [], Some $1, close
+  }
+| End {
+   [], None, $1
+  }
+
+field_or_end:
+  End {
+    `End $1 }
+| field_assignment after_field {
+    let fields, term, close = $2 in
+    `Some ($1, fields, term, close)
+  }
+
+field_assignment:
+  field_name EQUAL expr {
+    let region = cover $1.region (expr_to_region $3)
+    and value = {
+      field_name = $1;
+      equal      = $2;
+      field_expr = $3}
+    in {region; value}
+  }
+
+record_projection:
+  record_name DOT field_name {
+    let region = cover $1.region $3.region in
+    let value  = {
+      record_name = $1;
+      selector    = $2;
+      field_name  = $3}
+    in {region; value}
+  }
+
+record_copy:
+  Copy record_name With record_injection {
+    let region = cover $1 $4.region in
+    let value  = {
+      kwd_copy    = $1;
+      record_name = $2;
+      kwd_with    = $3;
+      delta       = $4}
+    in {region; value}
+  }
 
 fun_call:
   fun_name arguments {

Tests/a.li

@@ -4,19 +4,30 @@ type v is record foo: key; bar: mutez; baz: address end
 type w is K of (U of int) (*v * u*)
 
 storage s : w     // Line comment
-operations o : u;
-
 type i is int;
+operations o : u;
+const pi : int = 314159
+
+const x : v =
+   record
+     foo = 4;
+     bar = 5;
+     baz = 0x3244
+   end
 
 (* Block comment *)
 
 entrypoint g (const l : list (int)) is
+
+  var y : v := copy x with record bar = 7 end;
+
   function f (const x : int) : int is
      var y : int := 5 - x
      const z : int = 6
      begin
        y := x + y
      end with y * 2
+
   begin
      match l with
         [] -> null