Fix comments around underscore in record patterns

CHANGES.md

@@ -48,6 +48,7 @@ profile. This started with version 0.26.0.
 - Fix formatting of type vars in GADT constructors (#2518, @Julow)
 - Fix `[@ocamlformat "disable"]` inside `class type` constructs. (#2525, @EmileTrotignon)
 - Fix the formatting of the `in` keyword when `[@ocamlformat disable]` is attached to a let-binding (#2242, @EmileTrotignon)
+- Fix comments around underscore in record patterns (#2540, @Julow)
 - Fix dropped comments before `begin .. end` in a match case (#2541, @Julow)
 
 ### Changes

lib/Fmt_ast.ml

@@ -1141,25 +1141,31 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
         in
         hvbox 0 @@ Cmts.fmt c ppat_loc @@ fmt_record_field c ?typ1 ?rhs lid
       in
-      let p1, p2 = Params.get_record_pat c.conf ~ctx:ctx0 in
+      let p = Params.get_record_pat c.conf ~ctx:ctx0 in
       let last_sep, fmt_underscore =
         match closed_flag with
         | OClosed -> (true, noop)
-        | OOpen loc -> (false, Cmts.fmt ~pro:(break 1 2) c loc p2.wildcard)
+        | OOpen loc ->
+            let underscore =
+              p.sep_before
+              $ hvbox 0 (Cmts.fmt c loc (str "_"))
+              $ p.sep_after_final
+            in
+            (false, underscore)
       in
-      let last_loc (lid, t, p) =
-        match (t, p) with
-        | _, Some p -> p.ppat_loc
+      let last_loc (lid, t, pat) =
+        match (t, pat) with
+        | _, Some pat -> pat.ppat_loc
         | Some t, _ -> t.ptyp_loc
         | _ -> lid.loc
       in
       let fmt_fields =
-        fmt_elements_collection c ~last_sep p1 last_loc ppat_loc fmt_field
+        fmt_elements_collection c ~last_sep p last_loc ppat_loc fmt_field
           flds
       in
       hvbox_if parens 0
         (Params.parens_if parens c.conf
-           (p1.box (fmt_fields $ fmt_underscore)) )
+           (p.box (fmt_fields $ fmt_underscore)) )
   | Ppat_array [] ->
       hvbox 0
         (wrap_fits_breaks c.conf "[|" "|]" (Cmts.fmt_within c ppat_loc))

lib/Params.ml

@@ -367,8 +367,6 @@ type elements_collection =
 
 type elements_collection_record_expr = {break_after_with: Fmt.t}
 
-type elements_collection_record_pat = {wildcard: Fmt.t}
-
 let get_record_expr (c : Conf.t) =
   let space = if c.fmt_opts.space_around_records.v then 1 else 0 in
   let dock = c.fmt_opts.dock_collection_brackets.v in
@@ -454,8 +452,7 @@ let get_record_pat (c : Conf.t) ~ctx =
         ~space_around:c.fmt_opts.space_around_records.v "{" "}"
     else params.box
   in
-  ( {params with box}
-  , {wildcard= params.sep_before $ str "_" $ params.sep_after_final} )
+  {params with box}
 
 let collection_pat (c : Conf.t) ~ctx ~space_around opn cls =
   let params = collection_expr c ~space_around opn cls in

lib/Params.mli

@@ -117,17 +117,14 @@ type elements_collection =
 
 type elements_collection_record_expr = {break_after_with: Fmt.t}
 
-type elements_collection_record_pat = {wildcard: Fmt.t}
-
 val get_record_expr :
   Conf.t -> elements_collection * elements_collection_record_expr
 
 val get_list_expr : Conf.t -> elements_collection
 
 val get_array_expr : Conf.t -> elements_collection
 
-val get_record_pat :
-  Conf.t -> ctx:Ast.t -> elements_collection * elements_collection_record_pat
+val get_record_pat : Conf.t -> ctx:Ast.t -> elements_collection
 
 val get_list_pat : Conf.t -> ctx:Ast.t -> elements_collection
 

test/passing/dune.inc

@@ -1256,6 +1256,42 @@
  (package ocamlformat)
  (action (diff tests/comments_in_local_let.ml.err comments_in_local_let.ml.stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to comments_in_record-break_separator-after.ml.stdout
+   (with-stderr-to comments_in_record-break_separator-after.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --break-separator=after %{dep:tests/comments_in_record.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/comments_in_record-break_separator-after.ml.ref comments_in_record-break_separator-after.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/comments_in_record-break_separator-after.ml.err comments_in_record-break_separator-after.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to comments_in_record-break_separator-before.ml.stdout
+   (with-stderr-to comments_in_record-break_separator-before.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --break-separator=before %{dep:tests/comments_in_record.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/comments_in_record-break_separator-before.ml.ref comments_in_record-break_separator-before.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/comments_in_record-break_separator-before.ml.err comments_in_record-break_separator-before.ml.stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)

test/passing/tests/break_collection_expressions-wrap.ml.err

@@ -1,2 +1,2 @@
 Warning: tests/break_collection_expressions.ml:3 exceeds the margin
-Warning: tests/break_collection_expressions.ml:50 exceeds the margin
+Warning: tests/break_collection_expressions.ml:49 exceeds the margin

test/passing/tests/break_collection_expressions-wrap.ml.ref

@@ -21,8 +21,7 @@ let [| fooooooooooooooooooooooooooooooo; fooooooooooooooooooooooooooooooo
 let { fooooooooooooooooooooooooooooooo
     ; fooooooooooooooooooooooooooooooo
     ; fooooooooooooooooooooooooooooooo
-    ; _
-      (* xxx *) } =
+    ; _ (* xxx *) } =
   { fooooooooooooooooooooooooooooooo= x
   ; fooooooooooooooooooooooooooooooo= y
   ; fooooooooooooooooooooooooooooooo= z (* after all fields *) }

test/passing/tests/break_collection_expressions.ml.ref

@@ -25,8 +25,7 @@ let [| fooooooooooooooooooooooooooooooo
 let { fooooooooooooooooooooooooooooooo
     ; fooooooooooooooooooooooooooooooo
     ; fooooooooooooooooooooooooooooooo
-    ; _
-      (* xxx *) } =
+    ; _ (* xxx *) } =
   { fooooooooooooooooooooooooooooooo= x
   ; fooooooooooooooooooooooooooooooo= y
   ; fooooooooooooooooooooooooooooooo= z (* after all fields *) }

test/passing/tests/comments_in_record-break_separator-after.ml.err

@@ -0,0 +1,2 @@
+Warning: tests/comments_in_record.ml:21 exceeds the margin
+Warning: tests/comments_in_record.ml:27 exceeds the margin

test/passing/tests/comments_in_record-break_separator-after.ml.opts

@@ -0,0 +1 @@
+--break-separator=after

test/passing/tests/comments_in_record-break_separator-after.ml.ref

@@ -0,0 +1,115 @@
+type t =
+  { a: int; (* some comment *)
+    b: float;
+    c: string;
+    d: [`something_looooooooooooooooooooooooooooooooong] }
+
+type t =
+  { a: int;  (** some comment *)
+    b: float;
+    c: string;
+    d: [`something_looooooooooooooooooooooooooooooooong] }
+
+type t = {a: int; (* Comment *) b: int (* Comment *)}
+
+type t =
+  { a: int; (* Comment *)
+    b: int (* Comment *) }
+[@@ocamlformat "type-decl=sparse"]
+
+let { (* cmts *)
+      pat;
+      loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong;
+      a;
+      (* b *) b;
+      (* c *) c;
+      d=
+        (* d *)
+        (D : loooooooooooooooooooooooooooooooooooooooooooooooooooooooong_int);
+      (* e *)
+      e: loooooooooooooooooooooooooooooooooooooooooooooooooooooooong_int } =
+  exp
+
+let x =
+  { (* Xxxx xxxxxxxx xxxxx xx xx xx xxxx xxxxxx - XXxx_xxxxx xxx'x. *)
+    Irure_sed_a.in_nisi_sed= Irure_sed_fugiat.LaboRum sint_sed;
+    in_ea_deserunt= nulla }
+
+type t =
+  { a: int option;
+        (* aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb
+           cccccccccccccccccccccccccccc ddddddddddddddddd eeeee *)
+    b: float
+        (* aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb
+           cccccccccccccccccccccccccccc ddddddddddddddddd eeeee *) }
+
+type t =
+  | Tuple of {elts: t vector; packed: bool}
+  | Struct of
+      { name: string;
+        elts: t vector (* possibly cyclic, name unique *);
+            [@compare.ignore] [@equal.ignore] [@sexp_drop_if fun _ -> true]
+        elts: t vector;
+            (* possibly cyclic, name unique *)
+            (* mooooooooooooooooooooooooooooooooooore comments *)
+            [@compare.ignore]
+            [@equal.ignore]
+            [@sexp_drop_if fun _ -> true]
+        packed: bool }
+  | Opaque of {name: string}
+[@@deriving compare, equal, hash, sexp]
+
+type t = {(* c *) c (* c' *): (* d *) d (* d' *)}
+
+let _ =
+  { (* a *) a (* a' *)= (* b *) b (* b' *);
+    (* c *) c (* c' *): (* d *) d (* d' *) = (* e *) e (* e' *);
+    (* f *) f (* f' *);
+    (* g *) g (* g' *)=
+      (* j *) ((* h *) h (* h' *) : (* i *) i (* i' *)) (* j' *) }
+
+let { (* a *) a (* a' *)= (* b *) b (* b' *);
+      (* c *) c (* c' *): (* d *) d (* d' *) = (* e *) e (* e' *);
+      (* f *) f (* f' *);
+      (* g *) g (* g' *)=
+        (* j *) ((* h *) h (* h' *) : (* i *) i (* i' *)) (* j' *) } =
+  x
+
+type program =
+  { prog_globals: global list; (* global variables *)
+    prog_struct_types: lltype list; (* data structures *)
+    prog_lib_funcs: func list (* library functions *) }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t;
+    mutable ci_spilled:
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *)
+      IntervalSet.t }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t;
+    mutable
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *)
+      ci_spilled:
+      IntervalSet.t }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t;
+    mutable ci_spilled
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *):
+      IntervalSet.t }
+
+let _ =
+  match c with
+  | { issuer= _;
+      (* TODO *)
+      _ } ->
+      ()
+  | {issuer= _; (* TODO *) _} -> ()
+  | {issuer= _; _ (* TODO *)} -> ()
+  | { issuer= _;
+      (* TODO *)
+      _
+      (* TODO *) } ->
+      ()
+  | {issuer= _; (* TODO *) _ (* TODO *)} -> ()

test/passing/tests/comments_in_record-break_separator-before.ml.err

@@ -0,0 +1 @@
+Warning: tests/comments_in_record.ml:21 exceeds the margin

test/passing/tests/comments_in_record-break_separator-before.ml.opts

@@ -0,0 +1 @@
+--break-separator=before

test/passing/tests/comments_in_record-break_separator-before.ml.ref

@@ -0,0 +1,115 @@
+type t =
+  { a: int (* some comment *)
+  ; b: float
+  ; c: string
+  ; d: [`something_looooooooooooooooooooooooooooooooong] }
+
+type t =
+  { a: int  (** some comment *)
+  ; b: float
+  ; c: string
+  ; d: [`something_looooooooooooooooooooooooooooooooong] }
+
+type t = {a: int (* Comment *); b: int (* Comment *)}
+
+type t =
+  { a: int (* Comment *)
+  ; b: int (* Comment *) }
+[@@ocamlformat "type-decl=sparse"]
+
+let { (* cmts *)
+      pat
+    ; loooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong
+    ; a
+    ; (* b *) b
+    ; (* c *) c
+    ; d=
+        (* d *)
+        (D : loooooooooooooooooooooooooooooooooooooooooooooooooooooooong_int)
+    ; (* e *)
+      e: loooooooooooooooooooooooooooooooooooooooooooooooooooooooong_int } =
+  exp
+
+let x =
+  { (* Xxxx xxxxxxxx xxxxx xx xx xx xxxx xxxxxx - XXxx_xxxxx xxx'x. *)
+    Irure_sed_a.in_nisi_sed= Irure_sed_fugiat.LaboRum sint_sed
+  ; in_ea_deserunt= nulla }
+
+type t =
+  { a: int option
+        (* aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb
+           cccccccccccccccccccccccccccc ddddddddddddddddd eeeee *)
+  ; b: float
+        (* aaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbbb
+           cccccccccccccccccccccccccccc ddddddddddddddddd eeeee *) }
+
+type t =
+  | Tuple of {elts: t vector; packed: bool}
+  | Struct of
+      { name: string
+      ; elts: t vector (* possibly cyclic, name unique *)
+            [@compare.ignore] [@equal.ignore] [@sexp_drop_if fun _ -> true]
+      ; elts: t vector
+            (* possibly cyclic, name unique *)
+            (* mooooooooooooooooooooooooooooooooooore comments *)
+            [@compare.ignore]
+            [@equal.ignore]
+            [@sexp_drop_if fun _ -> true]
+      ; packed: bool }
+  | Opaque of {name: string}
+[@@deriving compare, equal, hash, sexp]
+
+type t = {(* c *) c (* c' *): (* d *) d (* d' *)}
+
+let _ =
+  { (* a *) a (* a' *)= (* b *) b (* b' *)
+  ; (* c *) c (* c' *): (* d *) d (* d' *) = (* e *) e (* e' *)
+  ; (* f *) f (* f' *)
+  ; (* g *) g (* g' *)=
+      (* j *) ((* h *) h (* h' *) : (* i *) i (* i' *)) (* j' *) }
+
+let { (* a *) a (* a' *)= (* b *) b (* b' *)
+    ; (* c *) c (* c' *): (* d *) d (* d' *) = (* e *) e (* e' *)
+    ; (* f *) f (* f' *)
+    ; (* g *) g (* g' *)=
+        (* j *) ((* h *) h (* h' *) : (* i *) i (* i' *)) (* j' *) } =
+  x
+
+type program =
+  { prog_globals: global list (* global variables *)
+  ; prog_struct_types: lltype list (* data structures *)
+  ; prog_lib_funcs: func list (* library functions *) }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t
+  ; mutable ci_spilled:
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *)
+      IntervalSet.t }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t
+  ; mutable
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *)
+      ci_spilled:
+      IntervalSet.t }
+
+type t =
+  { mutable ci_fixed: IntervalSet.t
+  ; mutable ci_spilled
+      (* spilled stack slots (reg.loc = Stack (Local n)) still in use *):
+      IntervalSet.t }
+
+let _ =
+  match c with
+  | { issuer= _
+    ; (* TODO *)
+      _ } ->
+      ()
+  | {issuer= _; (* TODO *) _} -> ()
+  | {issuer= _; _ (* TODO *)} -> ()
+  | { issuer= _
+    ; (* TODO *)
+      _
+      (* TODO *) } ->
+      ()
+  | {issuer= _; (* TODO *) _ (* TODO *)} -> ()