Merge branch 'MAIN' into pattern-attr-indent

CHANGES.md

@@ -65,7 +65,7 @@ profile. This started with version 0.26.0.
 - \* Improve formatting of functor arguments (#2505, @Julow)
   This also reduce the indentation of functor arguments with long signatures.
 
-- Improvements to the Janestreet profile (#2445, #2314, #2460, #2593, @Julow, @tdelvecchio-jsc)
+- Improvements to the Janestreet profile (#2445, #2314, #2460, #2593, #2612, @Julow, @tdelvecchio-jsc)
 
 - \* Undo let-bindings and methods normalizations (#2523, #2529, @gpetiot)
   This remove the rewriting of some forms of let-bindings and methods:
@@ -111,6 +111,7 @@ profile. This started with version 0.26.0.
 - Fix formatting of paragraphs in lists in documentation (#2607, @Julow)
 - Avoid unwanted space in references and links text in documentation (#2608, @Julow)
 - \* Improve the indentation of attributes in patterns (#2613, @Julow)
+- \* Avoid large indentation in patterns after `let%ext` (#2615, @Julow)
 
 ## 0.26.2 (2024-04-18)
 

lib/Fmt.ml

@@ -143,7 +143,7 @@ let utf8_length s =
 let str_as n s =
   let stack = Box_debug.get_stack () in
   with_pp (fun fs ->
-      Box_debug.start_str fs ;
+      Box_debug.start_str fs s ;
       Format_.pp_print_as fs n s ;
       Box_debug.end_str ~stack fs )
 

lib/Fmt_ast.ml

@@ -3455,12 +3455,12 @@ and fmt_label_declaration c ctx ?(last = false) decl =
              (fits_breaks ~level:5 "" ";") )
           (str ";")
   in
+  let indent_cmts = Params.Indent.record_docstring c.conf in
   hovbox 0
     ( Cmts.fmt_before c pld_loc
-    $ hvbox
-        (Params.Indent.record_docstring c.conf)
+    $ hvbox indent_cmts
         ( hvbox 3
-            ( hvbox 4
+            ( hvbox indent_cmts
                 ( hvbox 2
                     ( hovbox 2
                         ( fmt_mutable_flag ~pro:noop ~epi:space_break c
@@ -4580,7 +4580,6 @@ and fmt_value_binding c ~ctx0 ~rec_flag ?in_ ?epi
         (max (c.conf.fmt_opts.let_binding_indent.v - 1) 0, false)
     | _ -> (c.conf.fmt_opts.let_binding_indent.v, false)
   in
-  let pat_has_cmt = Cmts.has_before c.cmts lb_pat.ast.ppat_loc in
   let toplevel, in_, epi, cmts_before, cmts_after =
     match in_ with
     | Some in_ ->
@@ -4600,13 +4599,16 @@ and fmt_value_binding c ~ctx0 ~rec_flag ?in_ ?epi
         , Cmts.Toplevel.fmt_after c lb_loc )
   in
   let ext = lb_attrs.attrs_extension in
+  let should_break_after_keyword =
+    Cmts.has_before c.cmts lb_pat.ast.ppat_loc || Option.is_some ext
+  in
   let decl =
     let decl =
       fmt_str_loc c lb_op
       $ fmt_extension_suffix c ext
       $ fmt_attributes c at_attrs
       $ fmt_if rec_flag (str " rec")
-      $ fmt_or pat_has_cmt space_break (str " ")
+      $ fmt_or should_break_after_keyword space_break (str " ")
     and pattern = fmt_pattern c lb_pat
     and args =
       fmt_if

lib/box_debug.ml

@@ -42,6 +42,11 @@ let css =
   .fits_or_breaks {
     background-color: red;
   }
+  .string_with_whitespaces {
+    background-color: yellow;
+    white-space: pre;
+  }
+
   .tooltiptext {
     visibility: hidden;
     width: min-content;
@@ -132,7 +137,15 @@ let force_newline ?stack fs =
   debugf fs "<div class=\"break force_newline\">force_newline%a</div>"
     stack_tooltip stack
 
-let start_str fs = debugf fs "<span class='string'>"
+let start_str fs s =
+  let extra_class =
+    match String.lfindi s ~f:(fun _ c -> Char.is_whitespace c) with
+    | Some _ ->
+        (* String contains whitespaces, color it *)
+        " string_with_whitespaces"
+    | None -> ""
+  in
+  debugf fs "<span class='string%s'>" extra_class
 
 let end_str ?stack fs = debugf fs "%a</span>" stack_tooltip stack
 

test/passing/dune.inc

@@ -3275,7 +3275,7 @@
  (action
   (with-stdout-to js_record.ml.stdout
    (with-stderr-to js_record.ml.stderr
-     (run %{bin:ocamlformat} --margin-check %{dep:tests/js_record.ml})))))
+     (run %{bin:ocamlformat} --margin-check --profile=janestreet --max-iter=3 %{dep:tests/js_record.ml})))))
 
 (rule
  (alias runtest)

test/passing/tests/eliom_ext.eliom

@@ -28,8 +28,9 @@ type some_type = int * string list [@@deriving json]
 
 type another_type = A of some_type | B of another_type [@@deriving json]]
 
-let%server ( (s : int Eliom_shared.React.S.t)
-           , (f : (?step:React.step -> int -> unit) Eliom_shared.Value.t) ) =
+let%server
+    ( (s : int Eliom_shared.React.S.t)
+    , (f : (?step:React.step -> int -> unit) Eliom_shared.Value.t) ) =
   Eliom_shared.React.S.create 0
 
 let%client incr_s () =

test/passing/tests/js_record.ml

@@ -101,3 +101,17 @@ type t =
     : Something_lengthy.t
         list
   }
+
+type t =
+  { for_intf : Dune_rules.Module_name.t list
+    (* direct module dependencies for the interface *)
+  ; for_impl : Dune_rules.Module_name.t list
+    (* direct module dependencies for the implementation *)
+}
+
+type t =
+  { for_intf : Dune_rules.Module_name.t list
+        (* direct module dependencies for the interface *)
+    (* direct module dependencies for the interface *)
+  ; for_impl : Dune_rules.Module_name.t list
+}

test/passing/tests/js_record.ml.opts

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

test/passing/tests/js_record.ml.ref

@@ -1,38 +1,52 @@
-type x = {foo: int; bar: int}
+type x =
+  { foo : int
+  ; bar : int
+  }
 
-let x = {x with foo= 3; bar= 5}
+let x = { x with foo = 3; bar = 5 }
 
 let x =
   { (* blah blah blah *)
-    foo= 3
-  ; bar= 5 }
+    foo = 3
+  ; bar = 5
+  }
+;;
 
-let x = [{x with foo= 3; bar= 5}]
+let x = [ { x with foo = 3; bar = 5 } ]
 
 let x =
   [ { (* blah blah blah *)
-      foo= 3
-    ; bar= 5 } ]
-
-let x = {M.x with M.foo= 3}
-
-let x = {x with M.foo= 3}
-
-let x = {M.foo= 3}
-
-let _ = {foo with Bar.field1= value1; field2= value2}
-
-let _ = {foo with Bar.field1= value1; field2= value2}
+      foo = 3
+    ; bar = 5
+    }
+  ]
+;;
+
+let x = { M.x with M.foo = 3 }
+let x = { x with M.foo = 3 }
+let x = { M.foo = 3 }
+let _ = { foo with Bar.field1 = value1; field2 = value2 }
+let _ = { foo with Bar.field1 = value1; field2 = value2 }
 
 (* multicomponent record module pathname *)
-let _ = {A.B.a= b; c= d}
-
-type t = {a: something_lengthy list list [@default String.Map.empty]}
-
-type t = {a: Something_lengthy.t list list [@default String.Map.empty]}
-
-type t = {a: something_lengthy list list}
-
-type t = {a: Something_lengthy.t list list}
-
-type t = {a: Something_lengthy.t list}
+let _ = { A.B.a = b; c = d }
+
+type t = { a : something_lengthy list list [@default String.Map.empty] }
+type t = { a : Something_lengthy.t list list [@default String.Map.empty] }
+type t = { a : something_lengthy list list }
+type t = { a : Something_lengthy.t list list }
+type t = { a : Something_lengthy.t list }
+
+type t =
+  { for_intf : Dune_rules.Module_name.t list
+    (* direct module dependencies for the interface *)
+  ; for_impl : Dune_rules.Module_name.t list
+    (* direct module dependencies for the implementation *)
+  }
+
+type t =
+  { for_intf : Dune_rules.Module_name.t list
+    (* direct module dependencies for the interface *)
+    (* direct module dependencies for the interface *)
+  ; for_impl : Dune_rules.Module_name.t list
+  }