Fix formatting of multiline non-wrapping comments (#1723)

Author: gpetiot

CHANGES.md

@@ -40,6 +40,8 @@
 
   + Do not consider leading star '*' when checking the diff of doc comments (#1712, @hhugo)
 
+  + Fix formatting of multiline non-wrapping comments (#1723, @gpetiot)
+
 #### Changes
 
   + Improve the diff of unstable docstrings displayed in error messages (#1654, @gpetiot)

lib/Cmt.ml

@@ -90,11 +90,11 @@ let fmt_multiline_cmt ?epi ~opn_pos ~starts_with_sp first_line tl_lines =
     in
     fmt_if_k (not first) sep $ sp $ str (String.rstrip s)
   in
-  vbox 0 (list_fl unindented fmt_line $ fmt_opt epi)
+  vbox 0 ~name:"multiline" (list_fl unindented fmt_line $ fmt_opt epi)
 
 type pos = Before | Within | After
 
-let fmt cmt src ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code pos =
+let fmt cmt ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code pos =
   let open Fmt in
   let fmt_asterisk_prefixed_lines lines =
     vbox 1
@@ -106,7 +106,6 @@ let fmt cmt src ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code pos =
             | _, Some _ -> str line $ fmt "@,*" ) )
   in
   let fmt_unwrapped_cmt {txt= s; loc} =
-    let begins_line = Source.begins_line src loc ~ignore_spaces:false in
     let is_sp = function ' ' | '\t' -> true | _ -> false in
     let epi =
       (* Preserve position of closing but strip empty lines at the end *)
@@ -119,8 +118,7 @@ let fmt cmt src ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code pos =
     in
     let stripped = String.rstrip s in
     match String.split_lines stripped with
-    | first_line :: (_ :: _ as tl)
-      when (not begins_line) && not (String.is_empty first_line) ->
+    | first_line :: (_ :: _ as tl) when not (String.is_empty first_line) ->
         if ocp_indent_compat then
           (* Not adding artificial breaks and keeping the comment contents
              verbatim will not interfere with ocp-indent. *)
@@ -159,7 +157,7 @@ let fmt cmt src ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code pos =
     match fmt_code source with
     | Ok formatted ->
         let cls : Fmt.s = if dollar_last then "$*)" else "*)" in
-        hvbox 2
+        hvbox 2 ~name:"code"
           (wrap "(*$" cls
              ( fmt "@;" $ formatted
              $ fmt_if (String.length str > 2) "@;<1 -2>" ) )

lib/Cmt.mli

@@ -25,7 +25,6 @@ type pos = Before | Within | After
 
 val fmt :
      t
-  -> Source.t
   -> wrap:bool
   -> ocp_indent_compat:bool
   -> fmt_code:(string -> (Fmt.t, unit) Result.t)

lib/Cmts.ml

@@ -347,12 +347,12 @@ let fmt_cmts_aux t (conf : Conf.t) cmts ~fmt_code pos =
   let groups =
     List.group cmts ~break:(break_comment_group t.source conf.margin)
   in
-  vbox 0
+  vbox 0 ~name:"cmts"
     (list_pn groups (fun ~prev:_ group ~next ->
          ( match group with
          | [] -> impossible "previous match"
          | [cmt] ->
-             Cmt.fmt cmt t.source ~wrap:conf.wrap_comments
+             Cmt.fmt cmt ~wrap:conf.wrap_comments
                ~ocp_indent_compat:conf.ocp_indent_compat
                ~fmt_code:(fmt_code conf) pos
          | group ->

test/passing/dune.inc

@@ -767,6 +767,18 @@
  (package ocamlformat)
  (action (diff tests/doc_comments-no-parse-docstrings.mli.ref doc_comments-no-parse-docstrings.mli.output)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+   (with-outputs-to doc_comments-no-wrap.mli.output
+     (run %{bin:ocamlformat} --no-wrap-comments %{dep:tests/doc_comments.mli}))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/doc_comments-no-wrap.mli.ref doc_comments-no-wrap.mli.output)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)

test/passing/tests/cinaps.ml

@@ -47,7 +47,7 @@ let foo = foo
    crash and the second become a mess *)
 
 (*$(**)"
-"*)
+  "*)
 
 (*$
   print_newline () ;

test/passing/tests/doc_comments-no-parse-docstrings.mli.ref

@@ -434,3 +434,13 @@ val k : int
     Phasellus et nisi id neque ultrices vestibulum vitae non tortor. Mauris
     aliquet at risus sed rhoncus. Ut condimentum rhoncus orci, sit amet
     eleifend erat tempus quis. *)
+
+(** {[(* a b *)]} *)
+
+val a :
+     fooooooooooooooooooooooooooo (** {[(* a b *)]} *)
+  -> fooooooooooooooooooooooooo
+
+type x = {a: t  (** {[(* a b *)]} *); b: [`A  (** {[(* a b *)]} *)]}
+
+type x = A of a  (** {[(* a b *)]} *) | B of b  (** {[(* a b *)]} *)

test/passing/tests/doc_comments-no-wrap.mli.opts

@@ -0,0 +1 @@
+--no-wrap-comments