Do not break before non-simple strings

Allow non-simple string to be at the end of a group. This formats
printf-style functions in a nicer way.

lib/Ast.ml

@@ -1486,7 +1486,8 @@ end = struct
     | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false
     (* Only strings fitting on the line are simple. *)
     | Pexp_constant {pconst_desc= Pconst_string (_, loc, None); _} ->
-        Exp.is_trivial exp || (Location.height loc = 1 && fit_margin c (width xexp))
+        Exp.is_trivial exp
+        || (Location.height loc = 1 && fit_margin c (width xexp))
     | Pexp_constant _ -> true
     | Pexp_field _ | Pexp_ident _ | Pexp_send _
      |Pexp_construct (_, None)

lib/Cmt.ml

@@ -60,8 +60,7 @@ let pp_error fs {kind; cmt_kind} =
   in
   match kind with
   | `Added x ->
-      Format.fprintf fs
-        "%!@{<loc>%a@}:@,@{<error>Error@}: %s %a added.\n%!"
+      Format.fprintf fs "%!@{<loc>%a@}:@,@{<error>Error@}: %s %a added.\n%!"
         Location.print_loc (loc x) s_kind pp_cmt x
   | `Dropped x ->
       Format.fprintf fs

lib/Cmts.ml

@@ -303,8 +303,7 @@ 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%!"
+    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

lib/Conf.ml

@@ -39,8 +39,7 @@ let warn ~loc fmt =
   Format.kasprintf
     (fun s ->
       warn_raw
-        (Format.asprintf
-           "%!@{<loc>%a@}:@,@{<warning>Warning@}: %s\n%!"
+        (Format.asprintf "%!@{<loc>%a@}:@,@{<warning>Warning@}: %s\n%!"
            Location.print_loc loc s ) )
     fmt
 
@@ -872,8 +871,7 @@ module Formatting = struct
       ; Decl.Value.make ~name:"space" `Space
           "$(b,space) prints a space inside the delimiter to indicate the \
            matching one is on a different line."
-      ; Decl.Value.make
-          ~name:"closing-on-separate-line"
+      ; Decl.Value.make ~name:"closing-on-separate-line"
           `Closing_on_separate_line
           "$(b, closing-on-separate-line) makes sure that the closing \
            delimiter is on its own line." ]
@@ -1536,8 +1534,7 @@ let parse_attr {attr_name= {txt; loc= _}; attr_payload; _} =
   | _ when String.is_prefix ~prefix:"ocamlformat." txt ->
       Error
         (`Msg
-          (Format.sprintf
-             "Invalid format: Unknown suffix %S"
+          (Format.sprintf "Invalid format: Unknown suffix %S"
              (String.chop_prefix_exn ~prefix:"ocamlformat." txt) ) )
   | _ -> Error `Ignore
 

lib/Conf_decl.ml

@@ -163,13 +163,11 @@ let in_attributes cond = function
 let maybe_empty = function "" -> "" | x -> " " ^ x
 
 let pp_deprecated ppf {dmsg; dversion= v} =
-  Format.fprintf ppf
-    "This option is deprecated since version %a.%s"
+  Format.fprintf ppf "This option is deprecated since version %a.%s"
     Version.pp v (maybe_empty dmsg)
 
 let pp_removed ppf {rmsg; rversion= v} =
-  Format.fprintf ppf
-    "This option has been removed in version %a.%s"
+  Format.fprintf ppf "This option has been removed in version %a.%s"
     Version.pp v (maybe_empty rmsg)
 
 let pp_from_src fs = function
@@ -189,8 +187,7 @@ 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"
+      Format.fprintf fs "%a -- Warning (redundant): %a"
         pp_from_src x pp_from r
 
 let loc_udapted_from = function
@@ -211,8 +208,7 @@ 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"
+  Format.asprintf "%s The flag is $(b,%s) by default.%s%a"
     doc default
     (in_attributes allow_inline kind)
     status_doc status
@@ -222,8 +218,7 @@ 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"
+  Format.asprintf "%s The default value is $(b,%s).%s%a"
     doc default
     (in_attributes allow_inline kind)
     status_doc status
@@ -332,8 +327,7 @@ 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"
+    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} =

lib/Docstring.ml

@@ -24,8 +24,7 @@ let parse_file location text =
   Odoc_parser.ast (Odoc_parser.parse_comment ~location ~text)
 
 let warn fmt warning =
-  Format.fprintf fmt
-    "Warning: Invalid documentation comment:@,%s\n%!"
+  Format.fprintf fmt "Warning: Invalid documentation comment:@,%s\n%!"
     (Odoc_parser.Warning.to_string warning)
 
 let is_tag_only =

lib/Fmt_ast.ml

@@ -1471,8 +1471,18 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args =
     let xexp = sub_exp ~ctx x in
     is_simple c.conf (expression_width c) xexp
   in
+  let should_break_after x = not (is_simple x)
+  and should_break_before ((_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 (_, _, None); _} -> false
+    | _ -> 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/Source.ml

@@ -105,8 +105,7 @@ let extend_loc_to_include_attributes (loc : Location.t) (l : attributes) =
     {loc with loc_end= {loc.loc_end with pos_cnum= loc_end.loc_end.pos_cnum}}
 
 let string_literal t mode loc =
-  Option.value_exn
-    ~message:"Parse error while reading string literal"
+  Option.value_exn ~message:"Parse error while reading string literal"
     (Literal_lexer.string mode (string_at t loc))
 
 let begins_line ?(ignore_spaces = true) t (l : Location.t) =

lib/Translation_unit.ml

@@ -55,8 +55,7 @@ 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"
+         (Printf.sprintf "git diff --no-index -u %S %S | sed '1,4d' 1>&2"
             p n ) ) ;
     Stdlib.Sys.remove p ;
     Stdlib.Sys.remove n

test/passing/tests/args_grouped.ml

@@ -43,8 +43,7 @@ let bottom_up fooooooooooo =
   let empty = Int.equal 0 !scheduled && Queue.is_empty pending in
   if empty then (
     remaining := 0 ;
-    L.progress
-      "Finished call graph scheduling, %d procs remaining (in, or reaching, cycles).@."
+    L.progress "Finished call graph scheduling, %d procs remaining (in, or reaching, cycles).@."
       (CallGraph.n_procs syntactic_call_graph) ;
     if Config.debug_level_analysis > 0 then CallGraph.to_dotty syntactic_call_graph "cycles.dot" ;
     foooooooooooooooooo )
@@ -81,16 +80,14 @@ let f =
     ~y
 
 let eradicate_meta_class_is_nullsafe =
-  register
-    ~id:"ERADICATE_META_CLASS_IS_NULLSAFE"
+  register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE"
     ~hum:"Class is marked @Nullsafe and has 0 issues"
       (* Should be enabled for special integrations *)
     ~enabled:false Info Eradicate (* TODO *)
     ~user_documentation:""
 
 let eradicate_meta_class_is_nullsafe =
-  register
-    ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" (* Should be enabled for special integrations *)
+  register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE" (* Should be enabled for special integrations *)
     ~hum:"Class is marked @Nullsafe and has 0 issues"
       (* Should be enabled for special integrations *)
     ~enabled:false Info

test/passing/tests/break_infix-fit-or-vertical.ml.ref

@@ -108,8 +108,7 @@ let term =
          & pos 0 (some (enum modes)) None
          & info [] ~docv:"ACTION"
              ~doc:
-               (Printf.sprintf
-                  "The cache-daemon action to perform (%s)"
+               (Printf.sprintf "The cache-daemon action to perform (%s)"
                   (Arg.doc_alts_enum modes) ) )
      in
      (config, mode)
@@ -124,8 +123,7 @@ let term =
       & pos 0 (some (enum modes)) None
       & info [] ~docv:"ACTION"
           ~doc:
-            (Printf.sprintf
-               "The cache-daemon action to perform (%s)"
+            (Printf.sprintf "The cache-daemon action to perform (%s)"
                (Arg.doc_alts_enum modes) ) )
   in
   (config, mode)

test/passing/tests/break_infix-wrap.ml.ref

@@ -65,8 +65,7 @@ let term =
          & pos 0 (some (enum modes)) None
          & info [] ~docv:"ACTION"
              ~doc:
-               (Printf.sprintf
-                  "The cache-daemon action to perform (%s)"
+               (Printf.sprintf "The cache-daemon action to perform (%s)"
                   (Arg.doc_alts_enum modes) ) )
      in
      (config, mode)
@@ -81,8 +80,7 @@ let term =
       & pos 0 (some (enum modes)) None
       & info [] ~docv:"ACTION"
           ~doc:
-            (Printf.sprintf
-               "The cache-daemon action to perform (%s)"
+            (Printf.sprintf "The cache-daemon action to perform (%s)"
                (Arg.doc_alts_enum modes) ) )
   in
   (config, mode)

test/passing/tests/break_infix.ml.ref

@@ -97,8 +97,7 @@ let term =
          & pos 0 (some (enum modes)) None
          & info [] ~docv:"ACTION"
              ~doc:
-               (Printf.sprintf
-                  "The cache-daemon action to perform (%s)"
+               (Printf.sprintf "The cache-daemon action to perform (%s)"
                   (Arg.doc_alts_enum modes) ) )
      in
      (config, mode)
@@ -113,8 +112,7 @@ let term =
       & pos 0 (some (enum modes)) None
       & info [] ~docv:"ACTION"
           ~doc:
-            (Printf.sprintf
-               "The cache-daemon action to perform (%s)"
+            (Printf.sprintf "The cache-daemon action to perform (%s)"
                (Arg.doc_alts_enum modes) ) )
   in
   (config, mode)

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

@@ -10,11 +10,11 @@ Warning: tests/doc_comments.mli:124 exceeds the margin
 Warning: tests/doc_comments.mli:328 exceeds the margin
 Warning: tests/doc_comments.mli:377 exceeds the margin
 Warning: tests/doc_comments.mli:384 exceeds the margin
-Warning: tests/doc_comments.mli:453 exceeds the margin
-Warning: tests/doc_comments.mli:467 exceeds the margin
-Warning: tests/doc_comments.mli:524 exceeds the margin
-Warning: tests/doc_comments.mli:554 exceeds the margin
+Warning: tests/doc_comments.mli:451 exceeds the margin
+Warning: tests/doc_comments.mli:465 exceeds the margin
+Warning: tests/doc_comments.mli:522 exceeds the margin
+Warning: tests/doc_comments.mli:552 exceeds the margin
+Warning: tests/doc_comments.mli:622 exceeds the margin
 Warning: tests/doc_comments.mli:624 exceeds the margin
-Warning: tests/doc_comments.mli:626 exceeds the margin
-Warning: tests/doc_comments.mli:647 exceeds the margin
-Warning: tests/doc_comments.mli:660 exceeds the margin
+Warning: tests/doc_comments.mli:645 exceeds the margin
+Warning: tests/doc_comments.mli:658 exceeds the margin

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

@@ -401,15 +401,13 @@ end
       #use "import.cinaps" ;;
 
       List.iter all_fields ~f:(fun (name, type_) ->
-          printf
-            "\nexternal get_%s\n: unit -> %s = \"get_%s\""
+          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\""
+          printf "\nexternal get_%s\n: unit -> %s = \"get_%s\""
             name type_ name )
     ]} *)
 

test/passing/tests/doc_comments.mli.err

@@ -10,11 +10,11 @@ Warning: tests/doc_comments.mli:124 exceeds the margin
 Warning: tests/doc_comments.mli:328 exceeds the margin
 Warning: tests/doc_comments.mli:377 exceeds the margin
 Warning: tests/doc_comments.mli:384 exceeds the margin
-Warning: tests/doc_comments.mli:453 exceeds the margin
-Warning: tests/doc_comments.mli:467 exceeds the margin
-Warning: tests/doc_comments.mli:524 exceeds the margin
-Warning: tests/doc_comments.mli:554 exceeds the margin
+Warning: tests/doc_comments.mli:451 exceeds the margin
+Warning: tests/doc_comments.mli:465 exceeds the margin
+Warning: tests/doc_comments.mli:522 exceeds the margin
+Warning: tests/doc_comments.mli:552 exceeds the margin
+Warning: tests/doc_comments.mli:616 exceeds the margin
 Warning: tests/doc_comments.mli:618 exceeds the margin
-Warning: tests/doc_comments.mli:620 exceeds the margin
-Warning: tests/doc_comments.mli:641 exceeds the margin
-Warning: tests/doc_comments.mli:654 exceeds the margin
+Warning: tests/doc_comments.mli:639 exceeds the margin
+Warning: tests/doc_comments.mli:652 exceeds the margin

test/passing/tests/doc_comments.mli.ref

@@ -401,15 +401,13 @@ end
       #use "import.cinaps" ;;
 
       List.iter all_fields ~f:(fun (name, type_) ->
-          printf
-            "\nexternal get_%s\n: unit -> %s = \"get_%s\""
+          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\""
+          printf "\nexternal get_%s\n: unit -> %s = \"get_%s\""
             name type_ name )
     ]} *)
 

test/passing/tests/source.ml.ref

@@ -9173,8 +9173,7 @@ let xxxxxx =
 let _ = fun (x : int as 'a) : (int as 'a) -> x
 
 let eradicate_meta_class_is_nullsafe =
-  register
-    ~id:"ERADICATE_META_CLASS_IS_NULLSAFE"
+  register ~id:"ERADICATE_META_CLASS_IS_NULLSAFE"
     ~hum:"Class is marked @Nullsafe and has 0 issues"
       (* Should be enabled for special integrations *)
     ~enabled:false Info Eradicate (* TODO *)

test/unit/test_eol_compat.ml

@@ -34,26 +34,22 @@ let _ =
       "\nlet _ = \"aaa\\n\n         e\"\n"
       ~lf:"\nlet _ = \"aaa\\n\n         e\"\n"
       ~crlf:"\r\nlet _ = \"aaa\\n\r\n         e\"\r\n"
-  ; test
-      "lf in string with exclude_locs (lf)"
+  ; test "lf in string with exclude_locs (lf)"
       ~exclude_locs:[(9, 26)]
       "\nlet _ = \"aaa\\n\n         e\"\n"
       ~lf:"\nlet _ = \"aaa\\n\n         e\"\n"
       ~crlf:"\r\nlet _ = \"aaa\\n\n         e\"\r\n"
-  ; test
-      "crlf in string with exclude_locs (lf)"
+  ; test "crlf in string with exclude_locs (lf)"
       ~exclude_locs:[(9, 27)]
       "\nlet _ = \"aaa\\n\r\n         e\"\n"
       ~lf:"\nlet _ = \"aaa\\n\r\n         e\"\n"
       ~crlf:"\r\nlet _ = \"aaa\\n\r\n         e\"\r\n"
-  ; test
-      "lf in string with exclude_locs (crlf)"
+  ; test "lf in string with exclude_locs (crlf)"
       ~exclude_locs:[(10, 27)]
       "\r\nlet _ = \"aaa\\n\n         e\"\r\n"
       ~lf:"\nlet _ = \"aaa\\n\n         e\"\n"
       ~crlf:"\r\nlet _ = \"aaa\\n\n         e\"\r\n"
-  ; test
-      "crlf in string with exclude_locs (crlf)"
+  ; test "crlf in string with exclude_locs (crlf)"
       ~exclude_locs:[(10, 28)]
       "\r\nlet _ = \"aaa\\n\r\n         e\"\r\n"
       ~lf:"\nlet _ = \"aaa\\n\r\n         e\"\n"

test/unit/test_translation_unit.ml

@@ -33,8 +33,7 @@ let test_parse_and_format_core_type =
   [ make_test "string" ~input:"string" ~expected:(Ok "string\n")
   ; make_test "int" ~input:"int" ~expected:(Ok "int\n")
   ; make_test "arrow" ~input:"int -> int" ~expected:(Ok "int -> int\n")
-  ; make_test "arrow2"
-      ~input:"  int    (* foo *) \n\n ->     int  (* bar *)"
+  ; make_test "arrow2" ~input:"  int    (* foo *) \n\n ->     int  (* bar *)"
       ~expected:(Ok "int (* foo *) -> int (* bar *)\n")
   ; make_test ";;" ~input:";;"
       ~expected:
@@ -116,8 +115,7 @@ File "<test>", line 1, characters 0-3:
 
 let test_parse_and_format_expression =
   let make_test = test_parse_and_format "expression" ~fg:Expression in
-  [ make_test "List.map"
-      ~input:"List.map (fun x->\nx*x) [(1 + 9); 2;3] "
+  [ make_test "List.map" ~input:"List.map (fun x->\nx*x) [(1 + 9); 2;3] "
       ~expected:(Ok "List.map (fun x -> x * x) [ 1 + 9; 2; 3 ]\n") ]
 
 let tests =