JaneStreet profile: treat comments as doc-comments

CHANGES.md

@@ -21,6 +21,7 @@
 - Restore short form formatting of record field aliases (#2282, @gpetiot)
 - Tweaks the JaneStreet profile to be more consistent with ocp-indent (#2214, #2281, #2284, #2289, #2299, #2302, #2309, #2310, #2311, #2313, #2316, @gpetiot, @Julow)
 - Improve formatting of class signatures (#2301, @gpetiot, @Julow)
+- JaneStreet profile: treat comments as doc-comments (#2261, @gpetiot)
 - Don't indent attributes after a let/val/external (#2317, @Julow)
 
 ### New features

lib/Cmts.ml

@@ -562,8 +562,33 @@ module Verbatim = struct
     $ wrap "(*" "*)" @@ str s
 end
 
-let fmt_cmt (cmt : Cmt.t) ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code
-    pos =
+module Ocp_indent_compat = struct
+  let fmt ~fmt_code conf (cmt : Cmt.t) (pos : Cmt.pos) ~post =
+    let pre, doc, post =
+      let lines = String.split_lines cmt.txt in
+      match lines with
+      | [] -> (false, cmt.txt, false)
+      | h :: _ ->
+          let pre = String.is_empty (String.strip h) in
+          let doc = if pre then String.lstrip cmt.txt else cmt.txt in
+          let doc = if Option.is_some post then String.rstrip doc else doc in
+          (pre, doc, Option.is_some post)
+    in
+    let parsed = Docstring.parse ~loc:cmt.loc doc in
+    (* Disable warnings when parsing fails *)
+    let quiet = Conf_t.Elt.make true `Default in
+    let conf = {conf with Conf.opr_opts= {conf.Conf.opr_opts with quiet}} in
+    let doc = Fmt_odoc.fmt_parsed conf ~fmt_code ~input:doc parsed in
+    let open Fmt in
+    fmt_if_k
+      (Poly.(pos = After) && String.contains cmt.txt '\n')
+      (break_unless_newline 1000 0)
+    $ wrap "(*" "*)"
+      @@ wrap_k (fmt_if pre "@;<1000 3>") (fmt_if post "@\n")
+      @@ doc
+end
+
+let fmt_cmt (conf : Conf.t) (cmt : Cmt.t) ~fmt_code pos =
   let mode =
     match cmt.txt with
     | "" -> impossible "not produced by parser"
@@ -582,24 +607,35 @@ let fmt_cmt (cmt : Cmt.t) ~wrap:wrap_comments ~ocp_indent_compat ~fmt_code
         let source = String.sub ~pos:1 ~len str in
         match fmt_code source with
         | Ok formatted -> `Code (formatted, cls)
-        | Error (`Msg _) -> `Unwrapped cmt )
+        | Error (`Msg _) -> `Unwrapped (cmt, None) )
     | str when Char.equal str.[0] '=' -> `Verbatim cmt.txt
     | _ -> (
-      match Asterisk_prefixed.split cmt with
-      | [] | [""] -> impossible "not produced by split_asterisk_prefixed"
-      | [""; ""] -> `Verbatim " "
-      | [text] when wrap_comments -> `Wrapped (text, "*)")
-      | [text; ""] when wrap_comments -> `Wrapped (text, " *)")
-      | [_] | [_; ""] -> `Unwrapped cmt
-      | lines -> `Asterisk_prefixed lines )
+        let cmt =
+          (* Windows compatibility *)
+          let filter = function '\r' -> false | _ -> true in
+          Cmt.create (String.filter cmt.txt ~f:filter) cmt.loc
+        in
+        match Asterisk_prefixed.split cmt with
+        | [] | [""] -> impossible "not produced by split_asterisk_prefixed"
+        (* Comments like [(*\n*)] would be normalized as [(* *)] *)
+        | [""; ""] when conf.fmt_opts.ocp_indent_compat.v ->
+            `Unwrapped (cmt, None)
+        | [""; ""] -> `Verbatim " "
+        | [text] when conf.fmt_opts.wrap_comments.v -> `Wrapped (text, "*)")
+        | [text; ""] when conf.fmt_opts.wrap_comments.v ->
+            `Wrapped (text, " *)")
+        | [_] -> `Unwrapped (cmt, None)
+        | [_; ""] -> `Unwrapped (cmt, Some `Ln)
+        | lines -> `Asterisk_prefixed lines )
   in
   let open Fmt in
   match mode with
   | `Verbatim x -> Verbatim.fmt x pos
   | `Code (x, cls) -> hvbox 2 @@ wrap "(*$@;" cls (x $ fmt "@;<1 -2>")
   | `Wrapped (x, epi) -> str "(*" $ fill_text x ~epi
-  | `Unwrapped x when ocp_indent_compat -> Verbatim.fmt x.txt pos
-  | `Unwrapped x -> Unwrapped.fmt x
+  | `Unwrapped (x, ln) when conf.fmt_opts.ocp_indent_compat.v ->
+      Ocp_indent_compat.fmt ~fmt_code conf x pos ~post:ln
+  | `Unwrapped (x, _) -> Unwrapped.fmt x
   | `Asterisk_prefixed x -> Asterisk_prefixed.fmt x
 
 let fmt_cmts_aux t (conf : Conf.t) cmts ~fmt_code pos =
@@ -612,10 +648,7 @@ let fmt_cmts_aux t (conf : Conf.t) cmts ~fmt_code pos =
     (list_pn groups (fun ~prev:_ group ~next ->
          ( match group with
          | [] -> impossible "previous match"
-         | [cmt] ->
-             fmt_cmt cmt ~wrap:conf.fmt_opts.wrap_comments.v
-               ~ocp_indent_compat:conf.fmt_opts.ocp_indent_compat.v
-               ~fmt_code:(fmt_code conf) pos
+         | [cmt] -> fmt_cmt conf cmt ~fmt_code:(fmt_code conf) pos
          | group ->
              list group "@;<1000 0>" (fun cmt ->
                  wrap "(*" "*)" (str (Cmt.txt cmt)) ) )
@@ -743,10 +776,11 @@ let remaining_locs t = Set.to_list t.remaining
 let is_docstring (conf : Conf.t) (Cmt.{txt; loc} as cmt) =
   match txt with
   | "" | "*" -> Either.Second cmt
-  | _ when Char.equal txt.[0] '*' ->
+  | _ when Char.equal txt.[0] '*' || conf.fmt_opts.ocp_indent_compat.v ->
       (* Doc comments here (comming directly from the lexer) include their
          leading star [*]. It is not part of the docstring and should be
-         dropped. *)
+         dropped. When [ocp-indent-compat] is set, regular comments are
+         treated as doc-comments. *)
       let txt = String.drop_prefix txt 1 in
       let cmt = Cmt.create txt loc in
       if conf.fmt_opts.parse_docstrings.v then Either.First cmt

lib/Conf.ml

@@ -109,6 +109,7 @@ let conventional_profile from =
   ; type_decl= elt `Compact
   ; type_decl_indent= elt 2
   ; wrap_comments= elt false
+  ; wrap_docstrings= elt true
   ; wrap_fun_args= elt true }
 
 let default_profile = conventional_profile
@@ -176,6 +177,7 @@ let ocamlformat_profile from =
   ; type_decl= elt `Compact
   ; type_decl_indent= elt 2
   ; wrap_comments= elt false
+  ; wrap_docstrings= elt true
   ; wrap_fun_args= elt true }
 
 let janestreet_profile from =
@@ -229,7 +231,7 @@ let janestreet_profile from =
   ; parens_ite= elt true
   ; parens_tuple= elt `Multi_line_only
   ; parens_tuple_patterns= elt `Multi_line_only
-  ; parse_docstrings= elt false
+  ; parse_docstrings= elt true
   ; parse_toplevel_phrases= elt false
   ; sequence_blank_line= elt `Compact
   ; sequence_style= elt `Terminator
@@ -242,6 +244,7 @@ let janestreet_profile from =
   ; type_decl= elt `Sparse
   ; type_decl_indent= elt 2
   ; wrap_comments= elt false
+  ; wrap_docstrings= elt false
   ; wrap_fun_args= elt false }
 
 let default =

lib/Conf_t.ml

@@ -117,6 +117,7 @@ type fmt_opts =
   ; type_decl: [`Compact | `Sparse] elt
   ; type_decl_indent: int elt
   ; wrap_comments: bool elt
+  ; wrap_docstrings: bool elt
   ; wrap_fun_args: bool elt }
 
 type opr_opts =

lib/Conf_t.mli

@@ -115,6 +115,7 @@ type fmt_opts =
   ; type_decl: [`Compact | `Sparse] elt
   ; type_decl_indent: int elt
   ; wrap_comments: bool elt  (** Wrap comments at margin. *)
+  ; wrap_docstrings: bool elt
   ; wrap_fun_args: bool elt }
 
 (** Options changing the tool's behavior *)

lib/Fmt_ast.ml

@@ -388,23 +388,8 @@ let virtual_or_override = function
 
 let fmt_parsed_docstring c ~loc ?pro ~epi str_cmt parsed =
   assert (not (String.is_empty str_cmt)) ;
-  let fmt_parsed parsed =
-    fmt_if (String.starts_with_whitespace str_cmt) " "
-    $ Fmt_odoc.fmt ~fmt_code:(c.fmt_code c.conf) parsed
-    $ fmt_if
-        (String.length str_cmt > 1 && String.ends_with_whitespace str_cmt)
-        " "
-  in
-  let fmt_raw str_cmt = str str_cmt in
-  let doc =
-    match parsed with
-    | _ when not c.conf.fmt_opts.parse_docstrings.v -> fmt_raw str_cmt
-    | Ok parsed -> fmt_parsed parsed
-    | Error msgs ->
-        if not c.conf.opr_opts.quiet.v then
-          List.iter msgs ~f:(Docstring.warn Format.err_formatter) ;
-        fmt_raw str_cmt
-  in
+  let fmt_code = c.fmt_code c.conf in
+  let doc = Fmt_odoc.fmt_parsed c.conf ~fmt_code ~input:str_cmt parsed in
   Cmts.fmt c loc
   @@ vbox_if (Option.is_none pro) 0 (fmt_opt pro $ wrap "(**" "*)" doc $ epi)
 
@@ -4466,7 +4451,7 @@ let fmt_file (type a) ~ctx ~fmt_code ~debug (fragment : a Extended_ast.t)
   | Expression, e ->
       fmt_expression c (sub_exp ~ctx:(Str (Ast_helper.Str.eval e)) e)
   | Repl_file, l -> fmt_repl_file c ctx l
-  | Documentation, d -> Fmt_odoc.fmt ~fmt_code:(c.fmt_code c.conf) d
+  | Documentation, d -> Fmt_odoc.fmt_ast ~fmt_code:(c.fmt_code c.conf) d
 
 let fmt_parse_result conf ~debug ast_kind ast source comments ~fmt_code =
   let cmts = Cmts.init ast_kind ~debug source ast comments in

lib/Fmt_odoc.ml

@@ -13,7 +13,7 @@ open Fmt
 open Odoc_parser.Ast
 module Loc = Odoc_parser.Loc
 
-type conf = {fmt_code: Fmt.code_formatter}
+type conf = {fmt_code: Fmt.code_formatter; wrap_docstrings: bool}
 
 (** Escape characters if they are not already escaped. [escapeworthy] should
     be [true] if the character should be escaped, [false] otherwise. *)
@@ -51,15 +51,17 @@ let split_on_whitespaces =
   String.split_on_chars ~on:['\t'; '\n'; '\011'; '\012'; '\r'; ' ']
 
 (** Escape special characters and normalize whitespaces *)
-let str_normalized ?(escape = escape_all) s =
-  split_on_whitespaces s
-  |> List.filter ~f:(Fn.non String.is_empty)
-  |> fun s -> list s "@ " (fun s -> escape s |> str)
+let str_normalized ?(escape = escape_all) c s =
+  if c.wrap_docstrings then
+    split_on_whitespaces s
+    |> List.filter ~f:(Fn.non String.is_empty)
+    |> fun s -> list s "@ " (fun s -> escape s |> str)
+  else str (escape s)
 
 let ign_loc ~f with_loc = f with_loc.Loc.value
 
-let fmt_verbatim_block s =
-  let force_break = String.contains s '\n' in
+let fmt_verbatim_block ~loc s =
+  let force_break = loc.Loc.start.line < loc.end_.line in
   let content =
     (* Literal newline to avoid indentation *)
     if force_break then wrap "\n" "@\n" (str s)
@@ -145,45 +147,50 @@ let block_element_should_break elem next =
    depending on [block_element_should_break] *)
 let list_block_elem elems f =
   list_pn elems (fun ~prev:_ elem ~next ->
-      let elem = elem.Loc.value in
       let break =
         match next with
         | Some {Loc.value= n; _}
           when block_element_should_break
-                 (elem :> block_element)
+                 (elem.value :> block_element)
                  (n :> block_element) ->
             fmt "\n@\n"
         | Some _ -> fmt "@\n"
         | None -> noop
       in
       f elem $ break )
 
-let space_elt : inline_element with_location = Loc.(at (span []) (`Space ""))
+let space_elt c : inline_element with_location =
+  Loc.(at (span []) (`Space (if c.wrap_docstrings then "" else " ")))
 
-let rec fmt_inline_elements elements =
+let non_wrap_space sp = if String.contains sp '\n' then fmt "@\n" else str sp
+
+let rec fmt_inline_elements c elements =
   let wrap_elements opn cls ~always_wrap hd = function
     | [] -> wrap_if always_wrap opn cls hd
-    | tl -> wrap opn cls (hd $ fmt_inline_elements (space_elt :: tl))
+    | tl -> wrap opn cls (hd $ fmt_inline_elements c (space_elt c :: tl))
   in
   let rec aux = function
     | [] -> noop
-    | `Space _ :: `Word w :: t ->
+    | `Space sp :: `Word w :: t ->
         (* Escape lines starting with '+' or '-' *)
         let escape =
           if String.length w > 0 && Char.(w.[0] = '+' || w.[0] = '-') then
             "\\"
           else ""
         in
-        cbreak ~fits:("", 1, "") ~breaks:("", 0, escape)
-        $ str_normalized w $ aux t
-    | `Space _ :: t -> fmt "@ " $ aux t
-    | `Word w :: t -> str_normalized w $ aux t
+        fmt_or_k c.wrap_docstrings
+          (cbreak ~fits:("", 1, "") ~breaks:("", 0, escape))
+          (non_wrap_space sp)
+        $ str_normalized c w $ aux t
+    | `Space sp :: t ->
+        fmt_or_k c.wrap_docstrings (fmt "@ ") (non_wrap_space sp) $ aux t
+    | `Word w :: t -> str_normalized c w $ aux t
     | `Code_span s :: t -> fmt_code_span s $ aux t
     | `Math_span s :: t -> fmt_math_span s $ aux t
     | `Raw_markup (lang, s) :: t ->
         let lang =
           match lang with
-          | Some l -> str_normalized l $ str ":"
+          | Some l -> str_normalized c l $ str ":"
           | None -> noop
         in
         wrap "{%%" "%%}" (lang $ str s) $ aux t
@@ -196,24 +203,27 @@ let rec fmt_inline_elements elements =
           | `Superscript -> "^"
           | `Subscript -> "_"
         in
-        hovbox
+        hovbox_if c.wrap_docstrings
           (1 + String.length s + 1)
-          (wrap_elements "{" "}" ~always_wrap:true (str_normalized s) elems)
+          (wrap_elements "{" "}" ~always_wrap:true (str_normalized c s) elems)
         $ aux t
     | `Reference (_kind, rf, txt) :: t ->
         let rf = wrap "{!" "}" (fmt_reference rf) in
         wrap_elements "{" "}" ~always_wrap:false rf txt $ aux t
     | `Link (url, txt) :: t ->
-        let url = wrap "{:" "}" (str_normalized url) in
-        hovbox 2 @@ wrap_elements "{" "}" ~always_wrap:false url txt $ aux t
+        let url = wrap "{:" "}" (str_normalized c url) in
+        hovbox_if c.wrap_docstrings 2
+        @@ wrap_elements "{" "}" ~always_wrap:false url txt
+        $ aux t
   in
   aux (List.map elements ~f:(ign_loc ~f:Fn.id))
 
-and fmt_nestable_block_element c = function
-  | `Paragraph elems -> fmt_inline_elements elems
+and fmt_nestable_block_element c elm =
+  match elm.Loc.value with
+  | `Paragraph elems -> fmt_inline_elements c elems
   | `Code_block (s1, s2) -> fmt_code_block c s1 s2
   | `Math_block s -> fmt_math_block s
-  | `Verbatim s -> fmt_verbatim_block s
+  | `Verbatim s -> fmt_verbatim_block ~loc:elm.location s
   | `Modules mods ->
       hovbox 0
         (wrap "{!modules:@," "@,}"
@@ -274,21 +284,42 @@ let fmt_tag c = function
   | `Closed -> fmt_tag_args c "closed"
   | `Canonical ref -> fmt_tag_args c "canonical" ~arg:(fmt_reference ref)
 
-let fmt_block_element c = function
+let fmt_block_element c elm =
+  match elm.Loc.value with
   | `Tag tag -> hovbox 2 (fmt_tag c tag)
   | `Heading (lvl, lbl, elems) ->
       let lvl = Int.to_string lvl in
       let lbl =
         match lbl with
-        | Some lbl -> str ":" $ str_normalized lbl
+        | Some lbl -> str ":" $ str_normalized c lbl
         | None -> noop
       in
       let elems =
-        if List.is_empty elems then elems else space_elt :: elems
+        if List.is_empty elems then elems else space_elt c :: elems
       in
-      hovbox 0 (wrap "{" "}" (str lvl $ lbl $ fmt_inline_elements elems))
-  | #nestable_block_element as elm ->
-      hovbox 0 (fmt_nestable_block_element c elm)
+      hovbox 0 (wrap "{" "}" (str lvl $ lbl $ fmt_inline_elements c elems))
+  | #nestable_block_element as value ->
+      hovbox 0 (fmt_nestable_block_element c {elm with value})
 
-let fmt ~fmt_code (docs : t) =
-  vbox 0 (list_block_elem docs (fmt_block_element {fmt_code}))
+let fmt_ast ?(wrap_docstrings = true) ~fmt_code (docs : t) =
+  let conf = {fmt_code; wrap_docstrings} in
+  vbox 0 (list_block_elem docs (fmt_block_element conf))
+
+let fmt_parsed (conf : Conf.t) ~fmt_code ~input:str_cmt parsed =
+  let open Fmt in
+  let fmt_parsed parsed =
+    fmt_if (String.starts_with_whitespace str_cmt) " "
+    $ fmt_ast ~wrap_docstrings:conf.fmt_opts.wrap_docstrings.v ~fmt_code
+        parsed
+    $ fmt_if
+        (String.length str_cmt > 1 && String.ends_with_whitespace str_cmt)
+        " "
+  in
+  let fmt_raw str_cmt = str str_cmt in
+  match parsed with
+  | _ when not conf.fmt_opts.parse_docstrings.v -> fmt_raw str_cmt
+  | Ok parsed -> fmt_parsed parsed
+  | Error msgs ->
+      if not conf.opr_opts.quiet.v then
+        List.iter msgs ~f:(Docstring.warn Format.err_formatter) ;
+      fmt_raw str_cmt

lib/Fmt_odoc.mli

@@ -9,4 +9,15 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val fmt : fmt_code:Fmt.code_formatter -> Odoc_parser.Ast.t -> Fmt.t
+val fmt_ast :
+     ?wrap_docstrings:bool
+  -> fmt_code:Fmt.code_formatter
+  -> Odoc_parser.Ast.t
+  -> Fmt.t
+
+val fmt_parsed :
+     Conf.t
+  -> fmt_code:Fmt.code_formatter
+  -> input:string
+  -> (Odoc_parser.Ast.t, Odoc_parser.Warning.t list) Result.t
+  -> Fmt.t