Break long string literal arguments

lib/Ast.ml

@@ -148,7 +148,11 @@ module Exp = struct
 
   let rec is_trivial exp =
     match exp.pexp_desc with
-    | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true
+    (* String literals using the heavy syntax are not trivial. *)
+    | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false
+    (* Short strings are trivial. *)
+    | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} ->
+        String.length str < 30
     | Pexp_constant _ | Pexp_field _ | Pexp_ident _ | Pexp_send _ -> true
     | Pexp_construct (_, exp) -> Option.for_all exp ~f:is_trivial
     | Pexp_prefix (_, e) -> is_trivial e
@@ -1514,7 +1518,11 @@ end = struct
   let rec is_simple (c : Conf.t) width ({ast= exp; _} as xexp) =
     let ctx = Exp exp in
     match exp.pexp_desc with
-    | Pexp_constant _ -> Exp.is_trivial exp
+    (* String literals using the heavy syntax are not simple. *)
+    | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false
+    (* Only strings fitting on the line are simple. *)
+    | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true
+    | Pexp_constant _ -> true
     | Pexp_field _ | Pexp_ident _ | Pexp_send _
      |Pexp_construct (_, None)
      |Pexp_variant (_, None) ->

lib/Cmts.ml

@@ -303,8 +303,8 @@ let rec place t loc_tree ?prev_loc ?deep_loc locs cmts =
 (** Relocate comments, for Ast transformations such as sugaring. *)
 let relocate (t : t) ~src ~before ~after =
   if t.debug then
-    Format.eprintf "relocate %a to %a and %a@\n%!" Location.fmt src
-      Location.fmt before Location.fmt after ;
+    Format.eprintf "relocate %a to %a and %a@\n%!"
+      Location.fmt src Location.fmt before Location.fmt after ;
   let merge_and_sort x y =
     List.rev_append x y
     |> List.sort ~compare:(Comparable.lift Location.compare_start ~f:Cmt.loc)

lib/Conf_decl.ml

@@ -187,8 +187,8 @@ let rec pp_from fs = function
   | `Profile (s, p) -> Format.fprintf fs " (profile %s%a)" s pp_from_src p
   | `Updated (x, None) -> pp_from_src fs x
   | `Updated (x, Some r) ->
-      Format.fprintf fs "%a -- Warning (redundant): %a" pp_from_src x pp_from
-        r
+      Format.fprintf fs "%a -- Warning (redundant): %a"
+        pp_from_src x pp_from r
 
 let loc_udapted_from = function
   | `Commandline -> Location.in_file "<command-line>"
@@ -208,7 +208,8 @@ let status_doc ppf = function
 
 let generated_flag_doc ~allow_inline ~doc ~kind ~default ~status =
   let default = if default then "set" else "unset" in
-  Format.asprintf "%s The flag is $(b,%s) by default.%s%a" doc default
+  Format.asprintf "%s The flag is $(b,%s) by default.%s%a"
+    doc default
     (in_attributes allow_inline kind)
     status_doc status
 
@@ -217,7 +218,8 @@ let generated_doc conv ~allow_inline ~doc ~kind ~default ~status =
   let default =
     if String.is_empty default_doc then "none" else default_doc
   in
-  Format.asprintf "%s The default value is $(b,%s).%s%a" doc default
+  Format.asprintf "%s The default value is $(b,%s).%s%a"
+    doc default
     (in_attributes allow_inline kind)
     status_doc status
 
@@ -325,13 +327,13 @@ module Value = struct
     | Some x -> (name, value, doc, `Deprecated x)
 
   let pp_deprecated s ppf {dmsg= msg; dversion= v} =
-    Format.fprintf ppf "Value `%s` is deprecated since version %a. %s" s
-      Version.pp v msg
+    Format.fprintf ppf "Value `%s` is deprecated since version %a. %s"
+      s Version.pp v msg
 
   let pp_deprecated_with_name ~opt ~val_ ppf {dmsg= msg; dversion= v} =
     Format.fprintf ppf
-      "option `%s`: value `%s` is deprecated since version %a. %s" opt val_
-      Version.pp v msg
+      "option `%s`: value `%s` is deprecated since version %a. %s"
+      opt val_ Version.pp v msg
 
   let status_doc s ppf = function
     | `Valid -> ()
@@ -360,8 +362,8 @@ module Value_removed = struct
       | Some {name; version; msg} ->
           Format.kasprintf
             (fun s -> Error (`Msg s))
-            "value `%s` has been removed in version %a.%s" name Version.pp
-            version (maybe_empty msg)
+            "value `%s` has been removed in version %a.%s"
+            name Version.pp version (maybe_empty msg)
       | None -> Arg.conv_parser conv s
     in
     Arg.conv (parse, Arg.conv_printer conv)

lib/Fmt_ast.ml

@@ -1516,21 +1516,23 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args =
       (list_fl args (fmt_arg c) $ fmt_if_k last global_epi)
     $ fmt_if_k (not last) (break 1 0)
   in
-  let is_simple (lbl, x) =
+  let is_simple (_lbl, x) =
     let xexp = sub_exp ~ctx x in
-    let output =
-      Cmts.preserve
-        ~cache_key:(Arg (lbl, x))
-        (fun () ->
-          let cmts = Cmts.drop_before c.cmts x.pexp_loc in
-          fmt_arg ~first:false ~last:false {c with cmts} (lbl, x) )
-        c.cmts
-    in
-    let breaks = String.(rstrip output |> is_substring ~substring:"\n   ") in
-    is_simple c.conf (expression_width c) xexp && not breaks
+    is_simple c.conf (expression_width c) xexp
+  in
+  let should_break_before x = not (is_simple x)
+  and should_break_after ((_lbl, exp) as y) =
+    match exp.pexp_desc with
+    (* Heavy syntax strings are not grouped. *)
+    | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> true
+    (* Non-simple strings are grouped but end a group. *)
+    | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} ->
+        String.length str * 3 > c.conf.fmt_opts.margin.v
+    | _ -> not (is_simple y)
   in
   let break x y =
-    Cmts.has_after c.cmts (snd x).pexp_loc || not (is_simple x && is_simple y)
+    Cmts.has_after c.cmts (snd x).pexp_loc
+    || should_break_after x || should_break_before y
   in
   let groups =
     if c.conf.fmt_opts.wrap_fun_args.v then List.group args ~break

lib/Migrate_ast.ml

@@ -92,6 +92,8 @@ module Location = struct
 
   let width x = Position.distance x.loc_start x.loc_end
 
+  let height x = x.loc_end.pos_lnum - x.loc_start.pos_lnum + 1
+
   let descending cmp a b = -cmp a b
 
   let compare_width_decreasing =

lib/Migrate_ast.mli

@@ -72,6 +72,9 @@ module Location : sig
 
   val width : t -> int
 
+  (* Number of line spanned by a location. *)
+  val height : t -> int
+
   val is_single_line : t -> int -> bool
 
   val of_lexbuf : Lexing.lexbuf -> t

lib/Translation_unit.ml

@@ -59,7 +59,8 @@ module Error = struct
     Out_channel.write_all n ~data:next ;
     ignore
       (Stdlib.Sys.command
-         (Printf.sprintf "git diff --no-index -u %S %S | sed '1,4d' 1>&2" p n) ) ;
+         (Printf.sprintf "git diff --no-index -u %S %S | sed '1,4d' 1>&2"
+            p n ) ) ;
     Stdlib.Sys.remove p ;
     Stdlib.Sys.remove n
 
@@ -117,8 +118,8 @@ module Error = struct
         if debug then print_diff input_name ~prev ~next ;
         if iteration <= 1 then
           Format.fprintf fmt
-            "%s: %S was not already formatted. ([max-iters = 1])\n%!" exe
-            input_name
+            "%s: %S was not already formatted. ([max-iters = 1])\n%!"
+            exe input_name
         else (
           Format.fprintf fmt
             "%s: Cannot process %S.\n\
@@ -183,7 +184,8 @@ let check_margin (conf : Conf.t) ~filename ~fmted =
   List.iteri (String.split_lines fmted) ~f:(fun i line ->
       if String.length line > conf.fmt_opts.margin.v then
         Format.fprintf Format.err_formatter
-          "Warning: %s:%i exceeds the margin\n%!" filename i )
+          "Warning: %s:%i exceeds the margin\n%!"
+          filename i )
 
 let with_optional_box_debug ~box_debug k =
   if box_debug then Fmt.with_box_debug k else k

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

@@ -401,14 +401,14 @@ end
       #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 )
     ]} *)
 
 (** {[
       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 )
     ]} *)
 
 (** {[

test/passing/tests/doc_comments.mli.ref

@@ -401,14 +401,14 @@ end
       #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 )
     ]} *)
 
 (** {[
       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 )
     ]} *)
 
 (** {[

test/passing/tests/infix_arg_grouping.ml

@@ -5,8 +5,8 @@ vbox 1
 ;;
 
 user_error
-  ( "version mismatch: .ocamlformat requested " ^ value ^ " but version is "
-  ^ Version.version )
+  ( "version mismatch: .ocamlformat requested "
+  ^ value ^ " but version is " ^ Version.version )
 ;;
 
 hvbox 1

test/unit/test_literal_lexer.ml

@@ -30,9 +30,11 @@ let tests_string =
   in
   List.concat
     [ [test_opt "string: not a string" {|hello|} `Preserve ~expected:None]
-    ; test "simple" {|"hello"|} ~expected_preserve:"hello"
-        ~expected_normalize:"hello"
-    ; test "numeric escapes" {|"\123 \xff \o234"|}
+    ; test "simple"
+        {|"hello"|}
+        ~expected_preserve:"hello" ~expected_normalize:"hello"
+    ; test "numeric escapes"
+        {|"\123 \xff \o234"|}
         ~expected_preserve:{|\123 \xff \o234|}
         ~expected_normalize:{|\123 \xff \o234|}
     ; test "raw tab"