Fix AST changed due to strings in code blocks (#2338)

* Define 'fmt_code' type

* Staged formatting of code blocks

This fixes "comment changed" issues due to string literals.

String literals that contain breaks must not be indented relative to the
containing box and use forced line breaks to ensure the string stays
equal.

Code blocks are evaluated before being inserted into the parent document
in order to be indented without changing string literals.

The margin have to be adjusted while formatting the code blocks.

The code block added to the test previously formatted to:

    (** {[
          let _ =
            {|
       Doc-comment contains code blocks that contains string with breaks and
       ending with trailing spaces.
      |}
        ]} *)

Which changed the string to start with 1 space instead of 3 and ending
with none instead of 2.

CHANGES.md

@@ -6,6 +6,7 @@
 
 ### Bug fixes
 
+- Fix formatting of string literals in code blocks (#2338, @Julow)
 - Improve formatting of module arguments (#2322, @Julow)
 - Consistent indentation of `@@ let+ x = ...` (#2315, @Julow)
 - Remove double parenthesis around tuple in a match (#2308, @Julow)

lib/Cmts.ml

@@ -562,8 +562,25 @@ module Verbatim = struct
     $ wrap "(*" "*)" @@ str s
 end
 
+module Cinaps = struct
+  open Fmt
+
+  (** Comments enclosed in [(*$], [$*)] are formatted as code. *)
+  let fmt ~cls code =
+    let wrap k = hvbox 2 (fmt "(*$" $ k $ fmt cls) in
+    match String.split_lines code with
+    | [] | [""] -> wrap (str " ")
+    | [line] -> wrap (fmt "@ " $ str line $ fmt "@;<1 -2>")
+    | lines ->
+        let fmt_line = function
+          | "" -> fmt "\n"
+          | line -> fmt "@\n" $ str line
+        in
+        wrap (list lines "" fmt_line $ fmt "@;<1000 -2>")
+end
+
 module Ocp_indent_compat = struct
-  let fmt ~fmt_code conf (cmt : Cmt.t) (pos : Cmt.pos) ~post =
+  let fmt ~fmt_code conf (cmt : Cmt.t) ~offset (pos : Cmt.pos) ~post =
     let pre, doc, post =
       let lines = String.split_lines cmt.txt in
       match lines with
@@ -578,7 +595,7 @@ module Ocp_indent_compat = struct
     (* 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 doc = Fmt_odoc.fmt_parsed conf ~fmt_code ~input:doc ~offset parsed in
     let open Fmt in
     fmt_if_k
       (Poly.(pos = After) && String.contains cmt.txt '\n')
@@ -605,7 +622,7 @@ let fmt_cmt (conf : Conf.t) (cmt : Cmt.t) ~fmt_code pos =
         let cls : Fmt.s = if dollar_suf then "$*)" else "*)" in
         let len = String.length str - if dollar_suf then 2 else 1 in
         let source = String.sub ~pos:1 ~len str in
-        match fmt_code source with
+        match fmt_code conf ~offset:4 source with
         | Ok formatted -> `Code (formatted, cls)
         | Error (`Msg _) -> `Unwrapped (cmt, None) )
     | str when Char.equal str.[0] '=' -> `Verbatim cmt.txt
@@ -631,10 +648,11 @@ let fmt_cmt (conf : Conf.t) (cmt : Cmt.t) ~fmt_code pos =
   let open Fmt in
   match mode with
   | `Verbatim x -> Verbatim.fmt x pos
-  | `Code (x, cls) -> hvbox 2 @@ wrap "(*$@;" cls (x $ fmt "@;<1 -2>")
+  | `Code (code, cls) -> Cinaps.fmt ~cls code
   | `Wrapped (x, epi) -> str "(*" $ fill_text x ~epi
   | `Unwrapped (x, ln) when conf.fmt_opts.ocp_indent_compat.v ->
-      Ocp_indent_compat.fmt ~fmt_code conf x pos ~post:ln
+      (* TODO: [offset] should be computed from location. *)
+      Ocp_indent_compat.fmt ~fmt_code conf x ~offset:2 pos ~post:ln
   | `Unwrapped (x, _) -> Unwrapped.fmt x
   | `Asterisk_prefixed x -> Asterisk_prefixed.fmt x
 
@@ -648,7 +666,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 conf cmt ~fmt_code:(fmt_code conf) pos
+         | [cmt] -> fmt_cmt conf cmt ~fmt_code pos
          | group ->
              list group "@;<1000 0>" (fun cmt ->
                  wrap "(*" "*)" (str (Cmt.txt cmt)) ) )

lib/Cmts.mli

@@ -47,7 +47,7 @@ val relocate_wrongfully_attached_cmts :
 val fmt_before :
      t
   -> Conf.t
-  -> fmt_code:(Conf.t -> Fmt.code_formatter)
+  -> fmt_code:Fmt_odoc.fmt_code
   -> ?pro:Fmt.t
   -> ?epi:Fmt.t
   -> ?eol:Fmt.t
@@ -60,7 +60,7 @@ val fmt_before :
 val fmt_after :
      t
   -> Conf.t
-  -> fmt_code:(Conf.t -> Fmt.code_formatter)
+  -> fmt_code:Fmt_odoc.fmt_code
   -> ?pro:Fmt.t
   -> ?epi:Fmt.t
   -> ?filter:(Cmt.t -> bool)
@@ -72,7 +72,7 @@ val fmt_after :
 val fmt_within :
      t
   -> Conf.t
-  -> fmt_code:(Conf.t -> Fmt.code_formatter)
+  -> fmt_code:Fmt_odoc.fmt_code
   -> ?pro:Fmt.t
   -> ?epi:Fmt.t
   -> Location.t
@@ -82,20 +82,12 @@ val fmt_within :
 
 module Toplevel : sig
   val fmt_before :
-       t
-    -> Conf.t
-    -> fmt_code:(Conf.t -> Fmt.code_formatter)
-    -> Location.t
-    -> Fmt.t
+    t -> Conf.t -> fmt_code:Fmt_odoc.fmt_code -> Location.t -> Fmt.t
   (** [fmt_before loc] formats the comments associated with [loc] that appear
       before [loc]. *)
 
   val fmt_after :
-       t
-    -> Conf.t
-    -> fmt_code:(Conf.t -> Fmt.code_formatter)
-    -> Location.t
-    -> Fmt.t
+    t -> Conf.t -> fmt_code:Fmt_odoc.fmt_code -> Location.t -> Fmt.t
   (** [fmt_after loc] formats the comments associated with [loc] that appear
       after [loc]. *)
 end

lib/Fmt.ml

@@ -355,5 +355,3 @@ let fill_text ?(epi = "") text =
                | Some _ when not (String.is_empty curr) -> fmt "@ "
                | _ -> noop )
          $ str epi ) )
-
-type code_formatter = string -> t or_error

lib/Fmt.mli

@@ -223,5 +223,3 @@ val hovbox_if : ?name:string -> bool -> int -> t -> t
 
 val fill_text : ?epi:string -> string -> t
 (** Format a non-empty string as filled text wrapped at the margin. *)
-
-type code_formatter = string -> t or_error

lib/Fmt_ast.ml

@@ -22,7 +22,7 @@ type c =
   ; debug: bool
   ; source: Source.t
   ; cmts: Cmts.t
-  ; fmt_code: Conf.t -> Fmt.code_formatter }
+  ; fmt_code: Fmt_odoc.fmt_code }
 
 module Cmts = struct
   include Cmts
@@ -388,10 +388,13 @@ let virtual_or_override = function
   | Cfk_concrete (Override, _) -> str "!"
   | Cfk_concrete (Fresh, _) -> noop
 
-let fmt_parsed_docstring c ~loc ?pro ~epi str_cmt parsed =
-  assert (not (String.is_empty str_cmt)) ;
-  let fmt_code = c.fmt_code c.conf in
-  let doc = Fmt_odoc.fmt_parsed c.conf ~fmt_code ~input:str_cmt parsed in
+let fmt_parsed_docstring c ~loc ?pro ~epi input parsed =
+  assert (not (String.is_empty input)) ;
+  let offset =
+    let pos = loc.Location.loc_start in
+    pos.pos_cnum - pos.pos_bol + 3
+  and fmt_code = c.fmt_code in
+  let doc = Fmt_odoc.fmt_parsed c.conf ~fmt_code ~offset ~input parsed in
   Cmts.fmt c loc
   @@ vbox_if (Option.is_none pro) 0 (fmt_opt pro $ wrap "(**" "*)" doc $ epi)
 
@@ -4472,17 +4475,26 @@ 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_ast c.conf ~fmt_code:(c.fmt_code c.conf) d
+  | Documentation, d -> Fmt_odoc.fmt_ast c.conf ~fmt_code:c.fmt_code 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
   let ctx = Top in
-  Ok (fmt_file ~ctx ~debug ast_kind source cmts conf ast ~fmt_code)
+  let code =
+    set_margin conf.Conf.fmt_opts.margin.v
+    $ fmt_file ~ctx ~debug ast_kind source cmts conf ast ~fmt_code
+  in
+  Ok (Format_.asprintf "%a" Fmt.eval code)
 
 let fmt_code ~debug =
-  let rec fmt_code (conf : Conf.t) s =
-    let warn = conf.fmt_opts.parse_toplevel_phrases.v in
+  let rec fmt_code (conf : Conf.t) ~offset s =
+    let {Conf.fmt_opts; _} = conf in
+    let conf =
+      (* Adjust margin according to [offset]. *)
+      let margin = {fmt_opts.margin with v= fmt_opts.margin.v - offset} in
+      {conf with fmt_opts= {fmt_opts with margin}}
+    in
+    let warn = fmt_opts.parse_toplevel_phrases.v in
     let input_name = !Location.input_name in
     match Parse_with_comments.parse_toplevel conf ~input_name ~source:s with
     | Either.First {ast; comments; source; prefix= _} ->

lib/Fmt_odoc.ml

@@ -13,7 +13,9 @@ open Fmt
 open Odoc_parser.Ast
 module Loc = Odoc_parser.Loc
 
-type c = {fmt_code: Fmt.code_formatter; conf: Conf.t}
+type fmt_code = Conf.t -> offset:int -> string -> string or_error
+
+type c = {fmt_code: fmt_code; conf: Conf.t}
 
 (** Escape characters if they are not already escaped. [escapeworthy] should
     be [true] if the character should be escaped, [false] otherwise. *)
@@ -83,16 +85,17 @@ let fmt_code_block c s1 s2 =
     else if String.length l = 0 then str "\n"
     else fmt "@," $ str l
   in
-  let fmt_no_code s =
+  let fmt_code s =
     let lines = String.split_lines s in
     let box = match lines with _ :: _ :: _ -> vbox 0 | _ -> hvbox 0 in
     box (wrap_code (vbox 0 (list_fl lines fmt_line)))
   in
-  let Odoc_parser.Loc.{location; value} = s2 in
+  let Odoc_parser.Loc.{location; value= original} = s2 in
   match s1 with
   | Some ({value= "ocaml"; _}, _) | None -> (
-    match c.fmt_code value with
-    | Ok formatted -> hvbox 0 (wrap_code formatted)
+    (* [offset] doesn't take into account code blocks nested into lists. *)
+    match c.fmt_code c.conf ~offset:2 original with
+    | Ok formatted -> fmt_code formatted
     | Error (`Msg message) ->
         ( match message with
         | "" -> ()
@@ -103,8 +106,8 @@ let fmt_code_block c s1 s2 =
                 { location
                 ; message= Format.sprintf "invalid code block: %s" message }
         ) ;
-        fmt_no_code value )
-  | Some _ -> fmt_no_code value
+        fmt_code original )
+  | Some _ -> fmt_code original
 
 let fmt_code_span s = hovbox 0 (wrap "[" "]" (str (escape_brackets s)))
 
@@ -310,20 +313,24 @@ let fmt_ast conf ~fmt_code (docs : t) =
   let c = {fmt_code; conf} in
   vbox 0 (list_block_elem docs (fmt_block_element c))
 
-let fmt_parsed (conf : Conf.t) ~fmt_code ~input:str_cmt parsed =
+let fmt_parsed (conf : Conf.t) ~fmt_code ~input ~offset parsed =
   let open Fmt in
+  let begin_space = String.starts_with_whitespace input in
+  let offset = offset + if begin_space then 1 else 0 in
+  let fmt_code conf ~offset:offset' input =
+    fmt_code conf ~offset:(offset + offset') input
+  in
   let fmt_parsed parsed =
-    fmt_if (String.starts_with_whitespace str_cmt) " "
+    fmt_if begin_space " "
     $ fmt_ast conf ~fmt_code parsed
     $ fmt_if
-        (String.length str_cmt > 1 && String.ends_with_whitespace str_cmt)
+        (String.length input > 1 && String.ends_with_whitespace input)
         " "
   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
+  | _ when not conf.fmt_opts.parse_docstrings.v -> str input
   | 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
+      str input

lib/Fmt_odoc.mli

@@ -9,12 +9,16 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val fmt_ast :
-  Conf.t -> fmt_code:Fmt.code_formatter -> Odoc_parser.Ast.t -> Fmt.t
+(** [offset] is the column at which the content of the comment begins. It is
+    used to adjust the margin. *)
+type fmt_code = Conf.t -> offset:int -> string -> string or_error
+
+val fmt_ast : Conf.t -> fmt_code:fmt_code -> Odoc_parser.Ast.t -> Fmt.t
 
 val fmt_parsed :
      Conf.t
-  -> fmt_code:Fmt.code_formatter
+  -> fmt_code:fmt_code
   -> input:string
+  -> offset:int
   -> (Odoc_parser.Ast.t, Odoc_parser.Warning.t list) Result.t
   -> Fmt.t

test/passing/tests/cinaps.ml.err

@@ -1 +0,0 @@
-Warning: tests/cinaps.ml:24 exceeds the margin

test/passing/tests/cinaps.ml.ref

@@ -22,7 +22,8 @@ let y = 2
   #use "import.cinaps" ;;
 
   List.iter all_fields ~f:(fun (name, type_) ->
-      printf "\nexternal get_%s\n  : unit -> %s = \"get_%s\"" name type_ name )
+      printf "\nexternal get_%s\n  : unit -> %s = \"get_%s\"" name type_
+        name )
 *)
 external get_name : unit -> string = "get_name"
 

test/passing/tests/crlf_to_crlf.ml.ref

@@ -16,7 +16,8 @@ foo
 
     {[
       let verbatim s =
-        s |> String.split_lines |> List.map ~f:String.strip
+        s |> String.split_lines
+        |> List.map ~f:String.strip
         |> fun s -> list s "@," Fmt.str
     ]} *)
 

test/passing/tests/crlf_to_lf.ml.ref

@@ -16,7 +16,8 @@ foo
 
     {[
       let verbatim s =
-        s |> String.split_lines |> List.map ~f:String.strip
+        s |> String.split_lines
+        |> List.map ~f:String.strip
         |> fun s -> list s "@," Fmt.str
     ]} *)
 

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

@@ -620,3 +620,10 @@ type x =
     \,d\xi
     }
 *)
+
+(** {[
+     let _ = {|
+        Doc-comment contains code blocks that contains string with breaks and
+        ending with trailing spaces.
+       |}
+   ]} *)

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

@@ -7,13 +7,14 @@ Warning: tests/doc_comments.mli:87 exceeds the margin
 Warning: tests/doc_comments.mli:96 exceeds the margin
 Warning: tests/doc_comments.mli:99 exceeds the margin
 Warning: tests/doc_comments.mli:104 exceeds the margin
-Warning: tests/doc_comments.mli:308 exceeds the margin
-Warning: tests/doc_comments.mli:354 exceeds the margin
-Warning: tests/doc_comments.mli:361 exceeds the margin
-Warning: tests/doc_comments.mli:426 exceeds the margin
-Warning: tests/doc_comments.mli:439 exceeds the margin
-Warning: tests/doc_comments.mli:496 exceeds the margin
-Warning: tests/doc_comments.mli:526 exceeds the margin
-Warning: tests/doc_comments.mli:596 exceeds the margin
-Warning: tests/doc_comments.mli:598 exceeds the margin
-Warning: tests/doc_comments.mli:615 exceeds the margin
+Warning: tests/doc_comments.mli:309 exceeds the margin
+Warning: tests/doc_comments.mli:355 exceeds the margin
+Warning: tests/doc_comments.mli:362 exceeds the margin
+Warning: tests/doc_comments.mli:427 exceeds the margin
+Warning: tests/doc_comments.mli:440 exceeds the margin
+Warning: tests/doc_comments.mli:497 exceeds the margin
+Warning: tests/doc_comments.mli:527 exceeds the margin
+Warning: tests/doc_comments.mli:597 exceeds the margin
+Warning: tests/doc_comments.mli:599 exceeds the margin
+Warning: tests/doc_comments.mli:616 exceeds the margin
+Warning: tests/doc_comments.mli:628 exceeds the margin

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

@@ -151,7 +151,8 @@ val x : x
 
     {[
       let verbatim s =
-        s |> String.split_lines |> List.map ~f:String.strip
+        s |> String.split_lines
+        |> List.map ~f:String.strip
         |> fun s -> list s "@," Fmt.str
     ]} *)
 
@@ -621,3 +622,11 @@ type x =
       \f\hat\xi\,e^{2 \pi i \xi x}
       \,d\xi
     } *)
+
+(** {[
+      let _ =
+        {|
+         Doc-comment contains code blocks that contains string with breaks and
+         ending with trailing spaces.
+        |}
+    ]} *)

test/passing/tests/doc_comments.mli

@@ -628,3 +628,10 @@ type x =
     \,d\xi
     }
 *)
+
+(** {[
+     let _ = {|
+        Doc-comment contains code blocks that contains string with breaks and
+        ending with trailing spaces.
+       |}
+   ]} *)