Fix record patterns

Author: Julow

lib/Fmt_ast.ml

@@ -1159,7 +1159,7 @@ 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 p = Params.get_record_pat c.conf ~ctx:ctx0 in
+      let p = Params.get_record_pat c.conf ~ctx:ctx0 pat in
       let last_sep, fmt_underscore =
         match closed_flag with
         | OClosed -> (true, noop)
@@ -1188,13 +1188,13 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
       hvbox 0
         (wrap_fits_breaks c.conf "[|" "|]" (Cmts.fmt_within c ppat_loc))
   | Ppat_array pats ->
-      let p = Params.get_array_pat c.conf ~ctx:ctx0 in
+      let p = Params.get_array_pat c.conf ~ctx:ctx0 pat in
       p.box
         (fmt_elements_collection c p Pat.location ppat_loc
            (sub_pat ~ctx >> fmt_pattern c >> hvbox 0)
            pats )
   | Ppat_list pats ->
-      let p = Params.get_list_pat c.conf ~ctx:ctx0 in
+      let p = Params.get_list_pat c.conf ~ctx:ctx0 pat in
       p.box
         (fmt_elements_collection c p Pat.location ppat_loc
            (sub_pat ~ctx >> fmt_pattern c >> hvbox 0)

lib/Params.ml

@@ -663,44 +663,48 @@ let get_list_expr (c : Conf.t) =
 let get_array_expr (c : Conf.t) =
   collection_expr c ~space_around:c.fmt_opts.space_around_arrays.v "[|" "|]"
 
-let box_pattern_docked (c : Conf.t) ~ctx ~space_around opn cls k =
+let box_pattern_docked (c : Conf.t) ~ctx ~space_around ~pat opn cls k =
   let space = if space_around then 1 else 0 in
   let indent_opn, indent_cls =
     match (ctx, c.fmt_opts.break_separators.v) with
     | Ast.Exp {pexp_desc= Pexp_match _ | Pexp_try _; _}, `Before ->
         (String.length opn - 3, 1 - String.length opn)
     | Ast.Exp {pexp_desc= Pexp_match _ | Pexp_try _; _}, `After -> (-3, 1)
-    | Ast.Exp {pexp_desc= Pexp_let _; _}, _ -> (-4, 0)
+    | Ast.Exp {pexp_desc= Pexp_let ({pvbs_bindings; _}, _, _); _}, _
+      when List.exists pvbs_bindings ~f:(fun b -> phys_equal b.pvb_pat pat)
+      ->
+        (-4, 0)
     | _ -> (0, 0)
   in
   hvbox indent_opn
     (wrap (str opn) (str cls) (break space 2 $ k $ break space indent_cls))
 
-let get_record_pat (c : Conf.t) ~ctx =
+let get_record_pat (c : Conf.t) ~ctx pat =
   let params, _ = get_record_expr c in
   let box =
     if c.fmt_opts.dock_collection_brackets.v then
       box_pattern_docked c ~ctx
-        ~space_around:c.fmt_opts.space_around_records.v "{" "}"
+        ~space_around:c.fmt_opts.space_around_records.v ~pat "{" "}"
     else params.box
   in
   {params with box}
 
-let collection_pat (c : Conf.t) ~ctx ~space_around opn cls =
+let collection_pat (c : Conf.t) ~ctx ~space_around ~pat opn cls =
   let params = collection_expr c ~space_around opn cls in
   let box =
     if c.fmt_opts.dock_collection_brackets.v then
-      box_collec c 0 >> box_pattern_docked c ~ctx ~space_around opn cls
+      box_collec c 0 >> box_pattern_docked c ~ctx ~space_around ~pat opn cls
     else params.box
   in
   {params with box}
 
-let get_list_pat (c : Conf.t) ~ctx =
-  collection_pat c ~ctx ~space_around:c.fmt_opts.space_around_lists.v "[" "]"
+let get_list_pat (c : Conf.t) ~ctx pat =
+  collection_pat c ~ctx ~space_around:c.fmt_opts.space_around_lists.v ~pat
+    "[" "]"
 
-let get_array_pat (c : Conf.t) ~ctx =
-  collection_pat c ~ctx ~space_around:c.fmt_opts.space_around_arrays.v "[|"
-    "|]"
+let get_array_pat (c : Conf.t) ~ctx pat =
+  collection_pat c ~ctx ~space_around:c.fmt_opts.space_around_arrays.v ~pat
+    "[|" "|]"
 
 type if_then_else =
   { box_branch: Fmt.t -> Fmt.t

lib/Params.mli

@@ -163,11 +163,11 @@ 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
+val get_record_pat : Conf.t -> ctx:Ast.t -> pattern -> elements_collection
 
-val get_list_pat : Conf.t -> ctx:Ast.t -> elements_collection
+val get_list_pat : Conf.t -> ctx:Ast.t -> pattern -> elements_collection
 
-val get_array_pat : Conf.t -> ctx:Ast.t -> elements_collection
+val get_array_pat : Conf.t -> ctx:Ast.t -> pattern -> elements_collection
 
 type if_then_else =
   { box_branch: Fmt.t -> Fmt.t

test/passing/dune.inc

@@ -4711,6 +4711,24 @@
  (package ocamlformat)
  (action (diff tests/record-402.ml.err record-402.ml.stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to record-default.ml.stdout
+   (with-stderr-to record-default.ml.stderr
+     (run %{bin:ocamlformat} --margin-check --profile=default --max-iter=3 %{dep:tests/record.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/record-default.ml.ref record-default.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/record-default.ml.err record-default.ml.stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)

test/passing/tests/record-402.ml.ref

@@ -58,3 +58,12 @@ type t =
   { xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx:
       YYYYYYYYYYYYYYYYYYYYY.t
         (* ____________________________________ *) }
+
+let _ =
+  let _ = function
+    | { foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+      ; foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo }
+      ->
+        ()
+  in
+  ()

test/passing/tests/record-default.ml.err

@@ -0,0 +1,2 @@
+Warning: tests/record.ml:8 exceeds the margin
+Warning: tests/record.ml:16 exceeds the margin

test/passing/tests/record-default.ml.opts

@@ -0,0 +1,2 @@
+--profile=default
+--max-iter=3

test/passing/tests/record-default.ml.ref

@@ -0,0 +1,68 @@
+type t = { x : int; y : int }
+
+let _ = { x = 1; y = 2 }
+let _ = { !e with a; b = c }
+let _ = { !(f e) with a; b = c }
+
+let _ =
+  {
+    !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+    with
+    a;
+    b = c;
+  }
+
+let _ =
+  {
+    !looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+    with
+    aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa;
+    b = c;
+  }
+
+let _ = { (a : t) with a; b; c }
+let _ = { (f a) with a; b; c }
+
+let _ =
+  {
+    (a;
+     a)
+    with
+    a;
+    b;
+    c;
+  }
+
+let _ = { (if x then e else e) with e1; e2 }
+let _ = { (match x with x -> e) with e1; e2 }
+let _ = { (x : x) with e1; e2 }
+let _ = { (x :> x) with e1; e2 }
+let _ = { (x#x) with e1; e2 }
+let f ~l:{ f; g } = e
+let f ?l:({ f; g }) = e
+let _ = { a; b = (match b with `A -> A | `B -> B | `C -> C : c); c }
+let a () = A { A.a : t }
+let x = { aaaaaaaaaa (* b *); b }
+let x = { aaaaaaaaaa (* b *); b }
+
+type t = { a : (module S); b : (module S) }
+
+let _ = { a = (module M : S); b = (module M : S) }
+let to_string { x; _ (* we should print y *) } = string_of_int x
+let { x : t } = x
+
+type t = {
+  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx :
+    YYYYYYYYYYYYYYYYYYYYY.t;
+      (* ____________________________________ *)
+}
+
+let _ =
+  let _ = function
+    | {
+        foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo;
+        foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo;
+      } ->
+        ()
+  in
+  ()

test/passing/tests/record-loose.ml.ref

@@ -58,3 +58,12 @@ type t =
   { xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx :
       YYYYYYYYYYYYYYYYYYYYY.t
         (* ____________________________________ *) }
+
+let _ =
+  let _ = function
+    | { foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+      ; foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo }
+      ->
+        ()
+  in
+  ()

test/passing/tests/record-tight_decl.ml.ref

@@ -58,3 +58,12 @@ type t =
   { xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx:
       YYYYYYYYYYYYYYYYYYYYY.t
         (* ____________________________________ *) }
+
+let _ =
+  let _ = function
+    | { foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+      ; foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo }
+      ->
+        ()
+  in
+  ()