janestreet: Always treat multiline {|delimited strings|} as though they are long (#2480)

Co-authored-by: David Vulakh <dvulakh@janestreet.com>

Author: dvulakh

lib/Conf.ml

@@ -50,6 +50,7 @@ let conventional_profile from =
   let elt content = Elt.make content from in
   { align_symbol_open_paren= elt true
   ; assignment_operator= elt `End_line
+  ; break_around_multiline_strings= elt false
   ; break_before_in= elt `Fit_or_vertical
   ; break_cases= elt `Fit
   ; break_collection_expressions= elt `Fit_or_vertical
@@ -118,6 +119,7 @@ let ocamlformat_profile from =
   let elt content = Elt.make content from in
   { align_symbol_open_paren= elt true
   ; assignment_operator= elt `End_line
+  ; break_around_multiline_strings= elt false
   ; break_before_in= elt `Fit_or_vertical
   ; break_cases= elt `Nested
   ; break_collection_expressions= elt `Fit_or_vertical
@@ -184,6 +186,7 @@ let janestreet_profile from =
   let elt content = Elt.make content from in
   { align_symbol_open_paren= elt false
   ; assignment_operator= elt `Begin_line
+  ; break_around_multiline_strings= elt true
   ; break_before_in= elt `Fit_or_vertical
   ; break_cases= elt `Fit_or_vertical
   ; break_collection_expressions=

lib/Conf_t.ml

@@ -55,6 +55,7 @@ type 'a elt = 'a Elt.t
 type fmt_opts =
   { align_symbol_open_paren: bool elt
   ; assignment_operator: [`Begin_line | `End_line] elt
+  ; break_around_multiline_strings: bool elt
   ; break_before_in: [`Fit_or_vertical | `Auto] elt
   ; break_cases:
       [`Fit | `Nested | `Toplevel | `Fit_or_vertical | `All | `Vertical] elt

lib/Conf_t.mli

@@ -51,6 +51,7 @@ type 'a elt = 'a Elt.t
 type fmt_opts =
   { align_symbol_open_paren: bool elt
   ; assignment_operator: [`Begin_line | `End_line] elt
+  ; break_around_multiline_strings: bool elt
   ; break_before_in: [`Fit_or_vertical | `Auto] elt
   ; break_cases:
       [`Fit | `Nested | `Toplevel | `Fit_or_vertical | `Vertical | `All] elt

lib/Fmt.mli

@@ -76,6 +76,9 @@ val char : char -> t
 val str : string -> t
 (** Format a string. *)
 
+val str_as : int -> string -> t
+(** [str_as a len] formats a string as if it were of length [len]. *)
+
 (** Primitive containers ------------------------------------------------*)
 
 val opt : 'a option -> ('a -> t) -> t

lib/Fmt_ast.ml

@@ -262,7 +262,15 @@ 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'
-      @@ wrap_k (str ("{" ^ delim ^ "|")) (str ("|" ^ delim ^ "}")) (str s)
+      @@ (* 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'
+        then str_as 1000
+        else str )
+        (Format_.sprintf "{%s|%s|%s}" delim s delim)
   | Pconst_string (_, loc', None) -> (
       let delim = ["@,"; "@;"] in
       let contains_pp_commands s =
@@ -513,18 +521,19 @@ let sequence_blank_line c (l1 : Location.t) (l2 : Location.t) =
       loop l1.loc_end (Cmts.remaining_before c.cmts l2)
   | `Compact -> false
 
-let fmt_quoted_string key ext s = function
-  | None ->
-      wrap_k (str (Format_.sprintf "{%s%s|" key ext)) (str "|}") (str s)
+let fmt_quoted_string c key ext s maybe_delim =
+  ( if c.conf.fmt_opts.break_around_multiline_strings.v && String.mem s '\n'
+    then str_as 1000
+    else str )
+  @@
+  match maybe_delim with
+  | None -> Format_.sprintf "{%s%s|%s|}" key ext s
   | Some delim ->
       let ext_and_delim =
         if String.is_empty delim then ext
         else Format_.sprintf "%s %s" ext delim
       in
-      wrap_k
-        (str (Format_.sprintf "{%s%s|" key ext_and_delim))
-        (str (Format_.sprintf "|%s}" delim))
-        (str s)
+      Format_.sprintf "{%s%s|%s|%s}" key ext_and_delim s delim
 
 let fmt_type_var s =
   str "'"
@@ -557,7 +566,7 @@ let rec fmt_extension_aux c ctx ~key (ext, pld) =
       assert (not (Cmts.has_after c.cmts pexp_loc)) ;
       assert (not (Cmts.has_before c.cmts pstr_loc)) ;
       assert (not (Cmts.has_after c.cmts pstr_loc)) ;
-      hvbox 0 (fmt_quoted_string (Ext.Key.to_string key) ext str delim)
+      hvbox 0 (fmt_quoted_string c (Ext.Key.to_string key) ext str delim)
   | _, PStr [({pstr_loc; _} as si)], (Pld _ | Str _ | Top)
     when Source.extension_using_sugar ~name:ext ~payload:pstr_loc ->
       fmt_structure_item c ~last:true ~ext ~semisemi:false (sub_str ~ctx si)

test/passing/tests/js_source.ml.err

@@ -1,5 +1,5 @@
 Warning: tests/js_source.ml:155 exceeds the margin
-Warning: tests/js_source.ml:9531 exceeds the margin
-Warning: tests/js_source.ml:9634 exceeds the margin
-Warning: tests/js_source.ml:9693 exceeds the margin
-Warning: tests/js_source.ml:9775 exceeds the margin
+Warning: tests/js_source.ml:9537 exceeds the margin
+Warning: tests/js_source.ml:9640 exceeds the margin
+Warning: tests/js_source.ml:9699 exceeds the margin
+Warning: tests/js_source.ml:9781 exceeds the margin

test/passing/tests/js_source.ml.ocp

@@ -3154,7 +3154,8 @@ module FM_valid = F (struct
     type t = int
   end)
 
-[%%expect {|
+[%%expect
+  {|
 module M_valid : S
 module FM_valid : S
 |}]
@@ -3170,7 +3171,8 @@ end = struct
   let x = ref 0
 end
 
-[%%expect {|
+[%%expect
+  {|
 module Foo : sig type t val x : t ref end
 |}]
 
@@ -3184,7 +3186,8 @@ end = struct
   let x = ref 0
 end
 
-[%%expect {|
+[%%expect
+  {|
 module Bar : sig type t [@@immediate] val x : t ref end
 |}]
 
@@ -3194,7 +3197,8 @@ let test f =
   Sys.time () -. start
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test : (unit -> 'a) -> float = <fun>
 |}]
 
@@ -3204,7 +3208,8 @@ let test_foo () =
   done
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test_foo : unit -> unit = <fun>
 |}]
 
@@ -3214,7 +3219,8 @@ let test_bar () =
   done
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test_bar : unit -> unit = <fun>
 |}]
 
@@ -10330,8 +10336,10 @@ zzzzzzzzzzzzzzzzzzzzzzzzzzzz
 *)
 (*$*)
 
-(*$ {|
-         f|} *)
+(*$
+  {|
+         f|}
+*)
 
 let () =
   match () with

test/passing/tests/js_source.ml.ref

@@ -3154,7 +3154,8 @@ module FM_valid = F (struct
     type t = int
   end)
 
-[%%expect {|
+[%%expect
+  {|
 module M_valid : S
 module FM_valid : S
 |}]
@@ -3170,7 +3171,8 @@ end = struct
   let x = ref 0
 end
 
-[%%expect {|
+[%%expect
+  {|
 module Foo : sig type t val x : t ref end
 |}]
 
@@ -3184,7 +3186,8 @@ end = struct
   let x = ref 0
 end
 
-[%%expect {|
+[%%expect
+  {|
 module Bar : sig type t [@@immediate] val x : t ref end
 |}]
 
@@ -3194,7 +3197,8 @@ let test f =
   Sys.time () -. start
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test : (unit -> 'a) -> float = <fun>
 |}]
 
@@ -3204,7 +3208,8 @@ let test_foo () =
   done
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test_foo : unit -> unit = <fun>
 |}]
 
@@ -3214,7 +3219,8 @@ let test_bar () =
   done
 ;;
 
-[%%expect {|
+[%%expect
+  {|
 val test_bar : unit -> unit = <fun>
 |}]
 
@@ -10330,8 +10336,10 @@ zzzzzzzzzzzzzzzzzzzzzzzzzzzz
 *)
 (*$*)
 
-(*$ {|
-         f|} *)
+(*$
+  {|
+         f|}
+*)
 
 let () =
   match () with