address comments (parsetree0 PPX roundtrips, nested rest, etc)

Author: tsnobip

compiler/ml/ast_iterator.ml

@@ -398,12 +398,13 @@ module P = struct
       iter_loc sub l;
       iter_opt (sub.pat sub) p
     | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p
-    | Ppat_record (lpl, _cf, _rest) ->
+    | Ppat_record (lpl, _cf, rest) ->
       List.iter
         (fun {lid; x = pat} ->
           iter_loc sub lid;
           sub.pat sub pat)
-        lpl
+        lpl;
+      iter_opt (sub.pat sub) rest
     | Ppat_array pl -> List.iter (sub.pat sub) pl
     | Ppat_or (p1, p2) ->
       sub.pat sub p1;

compiler/ml/ast_mapper_from0.ml

@@ -576,7 +576,8 @@ module P = struct
       construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
     | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
     | Ppat_record (lpl, cf) ->
-      record ~loc ~attrs
+      let rest, attrs = Parsetree0.get_record_rest_attr attrs in
+      record ~loc ~attrs ?rest
         (Ext_list.map lpl (fun (lid, p) ->
              let lid1 = map_loc sub lid in
              let p1 = sub.pat sub p in

compiler/ml/ast_mapper_to0.ml

@@ -559,7 +559,13 @@ module P = struct
     | Ppat_construct (l, p) ->
       construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p)
     | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p)
-    | Ppat_record (lpl, cf, _rest) ->
+    | Ppat_record (lpl, cf, rest) ->
+      let attrs =
+        match rest with
+        | None -> attrs
+        | Some rest_pat ->
+          Parsetree0.add_record_rest_attr ~rest:(sub.pat sub rest_pat) attrs
+      in
       record ~loc ~attrs
         (Ext_list.map lpl (fun {lid; x = p; opt = optional} ->
              let lid1 = map_loc sub lid in

compiler/ml/depend.ml

@@ -188,7 +188,8 @@ let rec add_pattern bv pat =
       (fun {lid = lbl; x = p} ->
         add bv lbl;
         add_pattern bv p)
-      pl
+      pl;
+    add_opt add_pattern bv _rest
   | Ppat_array pl -> List.iter (add_pattern bv) pl
   | Ppat_or (p1, p2) ->
     add_pattern bv p1;

compiler/ml/matching.ml

@@ -543,6 +543,14 @@ let simplify_or p =
   in
   try simpl_rec p with Var p -> p
 
+let bind_record_rest loc arg rest action =
+  Llet
+    ( Strict,
+      Pgenval,
+      rest.rest_ident,
+      Lprim (Precord_spread_new rest.excluded_labels, [arg], loc),
+      action )
+
 let simplify_cases args cls =
   match args with
   | [] -> assert false
@@ -560,7 +568,12 @@ let simplify_cases args cls =
         | Tpat_record (lbls, closed, rest) ->
           let all_lbls = all_record_args lbls in
           let full_pat =
-            {pat with pat_desc = Tpat_record (all_lbls, closed, rest)}
+            {pat with pat_desc = Tpat_record (all_lbls, closed, None)}
+          in
+          let action =
+            match rest with
+            | None -> action
+            | Some rest -> bind_record_rest pat.pat_loc arg rest action
           in
           (full_pat :: patl, action) :: simplify rem
         | Tpat_or _ -> (
@@ -617,8 +630,11 @@ let rec extract_vars r p =
   | Tpat_var (id, _) -> IdentSet.add id r
   | Tpat_alias (p, id, _) -> extract_vars (IdentSet.add id r) p
   | Tpat_tuple pats -> List.fold_left extract_vars r pats
-  | Tpat_record (lpats, _, _rest) ->
-    List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats
+  | Tpat_record (lpats, _, rest) -> (
+    let r = List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats in
+    match rest with
+    | None -> r
+    | Some rest -> IdentSet.add rest.rest_ident r)
   | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats
   | Tpat_array pats -> List.fold_left extract_vars r pats
   | Tpat_variant (_, Some p, _) -> extract_vars r p
@@ -2742,32 +2758,7 @@ let partial_function loc () =
       ],
       loc )
 
-(* For record patterns with rest, inject the rest binding into the action body *)
-let inject_record_rest_binding param (pat, action) =
-  match pat.pat_desc with
-  | Tpat_record (_, _, Some rest) ->
-    let action_with_rest =
-      Llet
-        ( Strict,
-          Pgenval,
-          rest.rest_ident,
-          Lprim (Precord_spread_new rest.excluded_labels, [param], pat.pat_loc),
-          action )
-    in
-    let pat_without_rest =
-      {
-        pat with
-        pat_desc =
-          (match pat.pat_desc with
-          | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None)
-          | _ -> pat.pat_desc);
-      }
-    in
-    (pat_without_rest, action_with_rest)
-  | _ -> (pat, action)
-
 let for_function loc repr param pat_act_list partial =
-  let pat_act_list = List.map (inject_record_rest_binding param) pat_act_list in
   compile_matching repr (partial_function loc) param pat_act_list partial
 
 (* In the following two cases, exhaustiveness info is not available! *)
@@ -2836,28 +2827,6 @@ let for_let loc param pat body =
   | Tpat_var (id, _) ->
     (* fast path, and keep track of simple bindings to unboxable numbers *)
     Llet (Strict, Pgenval, id, param, body)
-  | Tpat_record (_, _, Some rest) ->
-    (* Record pattern with rest: compile the explicit field bindings normally,
-       then add a binding for the rest ident using Precord_spread_new *)
-    let body_with_rest =
-      Llet
-        ( Strict,
-          Pgenval,
-          rest.rest_ident,
-          Lprim (Precord_spread_new rest.excluded_labels, [param], loc),
-          body )
-    in
-    (* Compile the explicit fields pattern (without rest) into the body *)
-    let pat_without_rest =
-      {
-        pat with
-        pat_desc =
-          (match pat.pat_desc with
-          | Tpat_record (fields, closed, _) -> Tpat_record (fields, closed, None)
-          | _ -> pat.pat_desc);
-      }
-    in
-    simple_for_let loc param pat_without_rest body_with_rest
   | _ -> simple_for_let loc param pat body
 
 (* Handling of tupled functions and matchings *)

compiler/ml/parsetree0.ml

@@ -597,6 +597,7 @@ and module_binding = {
 
 let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr [])
 let optional_attr0 = (Location.mknoloc "res.optional", PStr [])
+let record_rest_attr_name = "res.record_rest"
 
 let add_optional_attr ~optional attrs =
   if optional then optional_attr0 :: attrs else attrs
@@ -608,3 +609,16 @@ let get_optional_attr attrs_ =
   let attrs = remove_optional_attr attrs_ in
   let optional = List.length attrs <> List.length attrs_ in
   (optional, attrs)
+
+let add_record_rest_attr ~rest attrs =
+  (Location.mknoloc record_rest_attr_name, PPat (rest, None)) :: attrs
+
+let get_record_rest_attr attrs_ =
+  let rec remove_record_rest_attr acc = function
+    | ({Location.txt = attr_name; _}, Parsetree.PPat (rest, None)) :: attrs
+      when attr_name = record_rest_attr_name ->
+      (Some rest, List.rev_append acc attrs)
+    | attr :: attrs -> remove_record_rest_attr (attr :: acc) attrs
+    | [] -> (None, List.rev acc)
+  in
+  remove_record_rest_attr [] attrs_

compiler/ml/typecore.ml

@@ -2237,7 +2237,9 @@ let iter_ppat f p =
   | Ppat_open (_, p)
   | Ppat_constraint (p, _) ->
     f p
-  | Ppat_record (args, _flag, _rest) -> List.iter (fun {x = p} -> f p) args
+  | Ppat_record (args, _flag, rest) ->
+    List.iter (fun {x = p} -> f p) args;
+    may f rest
 
 let contains_polymorphic_variant p =
   let rec loop p =

compiler/ml/typedtree.ml

@@ -500,6 +500,16 @@ let rec alpha_pat env p =
     let new_p = alpha_pat env p1 in
     try {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
     with Not_found -> new_p)
+  | Tpat_record (lpats, closed, Some rest) ->
+    let rest_ident =
+      try alpha_var env rest.rest_ident with Not_found -> rest.rest_ident
+    in
+    let lpats =
+      List.map
+        (fun (lid, lbl, pat, opt) -> (lid, lbl, alpha_pat env pat, opt))
+        lpats
+    in
+    {p with pat_desc = Tpat_record (lpats, closed, Some {rest with rest_ident})}
   | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d}
 
 let mkloc = Location.mkloc

compiler/syntax/src/res_core.ml

@@ -76,6 +76,11 @@ module ErrorMessages = struct
     "Record rest patterns require a type annotation and a binding name.\n\
      Correct syntax: `...typeName as bindingName`\n\
      Example: `let {name, ...Config.t as rest} = myRecord`"
+
+  let record_pattern_multiple_rest =
+    "Record patterns can only have one `...` rest clause.\n\
+     Use a single `...typeName as bindingName` clause to capture the remaining \
+     fields."
   (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *)
   [@@live]
 
@@ -1549,7 +1554,13 @@ and parse_record_pattern ~attrs p =
              Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p
                (Diagnostics.message ErrorMessages.record_pattern_spread));
           (field :: fields, flag, rest)
-        | PatRest rest_pat -> (fields, flag, Some rest_pat)
+        | PatRest rest_pat -> (
+          match rest with
+          | None -> (fields, flag, Some rest_pat)
+          | Some _ ->
+            Parser.err ~start_pos:rest_pat.Parsetree.ppat_loc.loc_start p
+              (Diagnostics.message ErrorMessages.record_pattern_multiple_rest);
+            (fields, flag, rest))
         | PatUnderscore -> (fields, flag, rest))
       ([], flag, None) raw_fields
   in

tests/syntax_tests/data/parsing/errors/other/expected/record_rest_duplicate.res.txt

@@ -0,0 +1,11 @@
+
+  Syntax error!
+  syntax_tests/data/parsing/errors/other/record_rest_duplicate.res:1:9-51
+
+  1 │ let {...Config.t as first, ...Config.t as second} = myRecord
+  2 │ 
+
+  Record patterns can only have one `...` rest clause.
+Use a single `...typeName as bindingName` clause to capture the remaining fields.
+
+let {  } = myRecord