Break around comments following an infix operator

CHANGES.md

@@ -26,6 +26,7 @@ profile. This started with version 0.26.0.
 - Fixed bug with attributes on sub-expressions of infix operators (#2459, @tdelvecchio-jsc)
 - \* Fix cinaps comment formatting to not change multiline string contents (#2463, @tdelvecchio-jsc)
 - Fix position of comments around function parameters (#2471, @gpetiot)
+- \* Force a break around comments following an infix operator (fix non-stabilizing comments) (#2478, @gpetiot)
 
 ## 0.26.1 (2023-09-15)
 

lib/Fmt_ast.ml

@@ -262,9 +262,10 @@ let fmt_constant c ?epi {pconst_desc; pconst_loc= loc} =
   | Pconst_char (_, s) -> wrap "'" "'" @@ str s
   | Pconst_string (s, loc', Some delim) ->
       Cmts.fmt c loc'
-      @@ (* If a multiline string has newlines in it, the configuration might
-            specify it should get treated as a "long" box element. To do so,
-            we pretend it is 1000 characters long. *)
+      @@
+      (* If a multiline string has newlines in it, the configuration might
+         specify it should get treated as a "long" box element. To do so, we
+         pretend it is 1000 characters long. *)
       ( if
           c.conf.fmt_opts.break_around_multiline_strings.v
           && String.mem s '\n'
@@ -1650,7 +1651,7 @@ and fmt_infix_op_args c ~parens xexp op_args =
                else fmt_if (not very_first) " "
              in
              match cmts_after with
-             | Some c -> (noop, op $ break $ c)
+             | Some c -> (noop, hovbox 0 (op $ fmt "@;" $ c))
              | None -> (op $ break, noop)
            in
            fmt_opt cmts_before $ before_arg
@@ -1939,8 +1940,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                     || Cmts.has_before c.cmts arg.ast.pexp_loc
                   then
                     Some
-                      ( Cmts.fmt_after c op.loc
-                      $ Cmts.fmt_before ~adj c arg.ast.pexp_loc )
+                      ( Cmts.fmt_after c ~epi:adj op.loc
+                      $ Cmts.fmt_before ~adj ~epi:adj c arg.ast.pexp_loc )
                   else None
                 in
                 let fmt_op = fmt_str_loc c op in

test/passing/dune.inc

@@ -2395,7 +2395,7 @@
 (rule
  (alias runtest)
  (package ocamlformat)
- (action (diff tests/infix_arg_grouping.ml infix_arg_grouping.ml.stdout)))
+ (action (diff tests/infix_arg_grouping.ml.ref infix_arg_grouping.ml.stdout)))
 
 (rule
  (alias runtest)
@@ -2408,7 +2408,7 @@
  (action
   (with-stdout-to infix_bind-break.ml.stdout
    (with-stderr-to infix_bind-break.ml.stderr
-     (run %{bin:ocamlformat} --margin-check --break-infix=wrap --break-infix-before-func %{dep:tests/infix_bind.ml})))))
+     (run %{bin:ocamlformat} --margin-check --break-infix=wrap --break-infix-before-func --max-iters=3 %{dep:tests/infix_bind.ml})))))
 
 (rule
  (alias runtest)
@@ -2426,7 +2426,7 @@
  (action
   (with-stdout-to infix_bind-fit_or_vertical-break.ml.stdout
    (with-stderr-to infix_bind-fit_or_vertical-break.ml.stderr
-     (run %{bin:ocamlformat} --margin-check --break-infix=fit-or-vertical --break-infix-before-func %{dep:tests/infix_bind.ml})))))
+     (run %{bin:ocamlformat} --margin-check --break-infix=fit-or-vertical --break-infix-before-func --max-iters=3 %{dep:tests/infix_bind.ml})))))
 
 (rule
  (alias runtest)

test/passing/tests/comments-no-wrap.ml.err

@@ -1,5 +1,4 @@
 Warning: tests/comments.ml:186 exceeds the margin
 Warning: tests/comments.ml:190 exceeds the margin
-Warning: tests/comments.ml:248 exceeds the margin
-Warning: tests/comments.ml:383 exceeds the margin
-Warning: tests/comments.ml:415 exceeds the margin
+Warning: tests/comments.ml:250 exceeds the margin
+Warning: tests/comments.ml:430 exceeds the margin

test/passing/tests/comments-no-wrap.ml.ref

@@ -194,12 +194,14 @@ type t =
 
 let () =
   xxxxxxxxxx
-  || (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
+  ||
+  (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
 let () =
   xxxxxxxxxx
-  land (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
+  land
+  (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
 let rec fooooooooooo = function
@@ -354,34 +356,47 @@ let a =
 
 let _ =
   1
-  + (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
+  +
+  (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
   fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-  - (* fooooooooooooo foooooooooooooooooooooo foooooooooooooooooooo *)
+  -
+  (* fooooooooooooo foooooooooooooooooooooo foooooooooooooooooooo *)
   foooooooooooooo foooooooooooooo foooooooooooooooooo fooooooooo
-  % (* foooooooooooooooo foooooooooooo foooooooooooooooooo *)
+  %
+  (* foooooooooooooooo foooooooooooo foooooooooooooooooo *)
   fooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-  / (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
+  /
+  (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
   barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
-  * (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  *
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  $ (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  $
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  & (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  &
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  = (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  =
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  > (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  >
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  < (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  <
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
   (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   @ foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  ^ (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  ^
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  || (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  ||
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo
     fooooooooooooooo
-    #= (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+    #=
+    (* convert from foos to bars blah blah blah blah blah blah blah blah *)
     foooooooooooooooooooooooo
     foooooooooooooooo fooooooooooooooo
 

test/passing/tests/comments.ml.err

@@ -1 +1 @@
-Warning: tests/comments.ml:250 exceeds the margin
+Warning: tests/comments.ml:252 exceeds the margin

test/passing/tests/comments.ml.ref

@@ -196,12 +196,14 @@ type t =
 
 let () =
   xxxxxxxxxx
-  || (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
+  ||
+  (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
 let () =
   xxxxxxxxxx
-  land (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
+  land
+  (* xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx *)
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
 
 let rec fooooooooooo = function
@@ -356,35 +358,47 @@ let a =
 
 let _ =
   1
-  + (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
+  +
+  (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
   fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-  - (* fooooooooooooo foooooooooooooooooooooo foooooooooooooooooooo *)
+  -
+  (* fooooooooooooo foooooooooooooooooooooo foooooooooooooooooooo *)
   foooooooooooooo foooooooooooooo foooooooooooooooooo fooooooooo
-  % (* foooooooooooooooo foooooooooooo foooooooooooooooooo *)
+  %
+  (* foooooooooooooooo foooooooooooo foooooooooooooooooo *)
   fooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
-  / (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
+  /
+  (* foooooooooooooooooooooooo fooooooooooooooo fooooooooooooooooo *)
   barrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrrr
-  * (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  *
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  $ (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  $
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  & (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  &
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  = (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  =
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  > (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  >
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  < (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  <
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
   (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   @ foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  ^ (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  ^
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo fooooooooooooooo
-  || (* convert from foos to bars blah blah blah blah blah blah blah blah *)
+  ||
+  (* convert from foos to bars blah blah blah blah blah blah blah blah *)
   foooooooooooooooooooooooo foooooooooooooooo
     fooooooooooooooo
-    #= (* convert from foos to bars blah blah blah blah blah blah blah
-          blah *)
+    #=
+    (* convert from foos to bars blah blah blah blah blah blah blah blah *)
     foooooooooooooooooooooooo
     foooooooooooooooo fooooooooooooooo
 

test/passing/tests/infix_arg_grouping.ml

@@ -128,3 +128,14 @@ let _ =
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
   >= (* ___________________________________ *)
   xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+let _ =
+    List.filter
+      (fun s ->
+         ((* 3.1. the sid of the authenticated user *)
+           foooooooooooooooooooooooooooooo
+           || (* 3.2. any sids of the group that authenticated the user *)
+           (* TODO: better to look up the membership closure *)
+           fooooooooooooooooooooooooooo
+         )
+      )

test/passing/tests/infix_arg_grouping.ml.ref

@@ -0,0 +1,144 @@
+vbox 1
+  ( str (Sexp.to_string_hum (Itv.sexp_of_t root))
+  $ wrap_if (not (List.is_empty children)) "@,{" " }" (dump_ tree children)
+  )
+;;
+
+user_error
+  ( "version mismatch: .ocamlformat requested " ^ value ^ " but version is "
+  ^ Version.version )
+;;
+
+hvbox 1
+  ( str "\""
+  $ list_pn lines (fun ?prev curr ?next ->
+        let drop = function ' ' -> true | _ -> false in
+        let line =
+          if Option.is_none prev then curr else String.lstrip ~drop curr
+        in
+        fmt_line line
+        $ opt next (fun next ->
+              let spc =
+                match String.lfindi next ~f:(fun _ c -> not (drop c)) with
+                | Some 0 -> ""
+                | Some i -> escape_string (String.sub next 0 i)
+                | None -> escape_string next
+              in
+              fmt "\\n"
+              $ fmt_if_k
+                  (not (String.is_empty next))
+                  (str spc $ pre_break 0 "\\" 0) ) )
+  $ str "\"" $ Option.call ~f:epi )
+;;
+
+hvbox 0
+  (wrap_fits_breaks "<" ">"
+     ( list fields "@ ; " (function
+         | Otag (lab_loc, attrs, typ) ->
+             (* label loc * attributes * core_type -> object_field *)
+             let doc, atrs = doc_atrs attrs in
+             let fmt_cmts = Cmts.fmt c lab_loc.loc in
+             fmt_cmts
+             @@ hvbox 4
+                  ( hvbox 2
+                      ( Cmts.fmt c lab_loc.loc @@ str lab_loc.txt
+                      $ fmt ":@ "
+                      $ fmt_core_type c (sub_typ ~ctx typ) )
+                  $ fmt_docstring c ~pro:(fmt "@;<2 0>") doc
+                  $ fmt_attributes c (fmt " ") ~key:"@" atrs (fmt "") )
+         | Oinherit typ -> fmt_core_type c (sub_typ ~ctx typ) )
+     $ fmt_if
+         Poly.(closedness = Open)
+         (match fields with [] -> "@ .. " | _ -> "@ ; .. ") ) )
+;;
+
+hvbox 0
+  ( fmt "functor@ "
+  $ wrap "(" ")"
+      ( str txt
+      $ opt mt (fun _ ->
+            fmt "@ : " $ Option.call ~f:pro_t $ psp_t $ fmt "@;<1 2>" $ bdy_t
+            $ esp_t $ Option.call ~f:epi_t ) )
+  $ fmt " ->@ " $ Option.call ~f:pro_e $ psp_e $ bdy_e $ esp_e
+  $ Option.call ~f:epi_e )
+
+let to_json {integers; floats; strings} =
+  `Assoc
+    [ ("int", yojson_of_integers integers)
+    ; ("double", yojson_of_floats floats)
+    ; ("normal", yojson_of_strings strings) ]
+  |> Yojson.Basic.to_string
+
+let rename (us, q) sub =
+  ( Var.Set.union
+      (Var.Set.diff us (Var.Subst.domain sub))
+      (Var.Subst.range sub)
+  , rename_q q sub )
+  |> check invariant
+
+let _ =
+  List.map ~f
+    ( [ aaaaaaaaaaaaaaa
+      ; bbbbbbbbbbbbbbb
+      ; ccccccccccccccc
+      ; ddddddddddddddd
+      ; eeeeeeeeeeeeeee ]
+    @ l )
+
+let sigma_seed =
+  create_seed_vars
+    ( (* formals already there plus new ones *)
+      prop.Prop.sigma @ sigma_new_formals )
+;;
+
+match
+  "\"" ^ line ^ " \""
+  |>
+  (* split by whitespace *)
+  Str.split (Str.regexp_string "\" \"")
+with
+| prog :: args -> fooooooooooooooooooooo
+
+let () =
+  (* Open the repo *)
+  initialise
+  >>=
+  (* Perform a subsequent action *)
+  subsequent_action
+  >|=
+  (* Keep going... *)
+  another_action
+  |> fun t ->
+  (* And finally do this *)
+  final_action t
+
+let () =
+  (* Open the repo *)
+  initialise
+  (* Perform a subsequent action *)
+  >>= subsequent_action
+  (* Keep going... *)
+  >|= another_action
+  (* And finally do this *)
+  |> fun t -> final_action t
+
+let _ =
+  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+  -
+  (* ___________________________________ *)
+  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+let _ =
+  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+  >=
+  (* ___________________________________ *)
+  xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+
+let _ =
+  List.filter (fun s ->
+      (* 3.1. the sid of the authenticated user *)
+      foooooooooooooooooooooooooooooo
+      ||
+      (* 3.2. any sids of the group that authenticated the user *)
+      (* TODO: better to look up the membership closure *)
+      fooooooooooooooooooooooooooo )