diff --git a/lib/Ast.ml b/lib/Ast.ml index 522342075d..06af05cbb8 100644 --- a/lib/Ast.ml +++ b/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) -> diff --git a/lib/Cmts.ml b/lib/Cmts.ml index e39a1e57e7..5527b322d5 100644 --- a/lib/Cmts.ml +++ b/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) diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml index e5b6c24eb3..9cf3379529 100644 --- a/lib/Conf_decl.ml +++ b/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 "" @@ -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) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d39a838cfb..140a121724 100644 --- a/lib/Fmt_ast.ml +++ b/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 diff --git a/lib/Migrate_ast.ml b/lib/Migrate_ast.ml index cd09bf4508..17c180d320 100644 --- a/lib/Migrate_ast.ml +++ b/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 = diff --git a/lib/Migrate_ast.mli b/lib/Migrate_ast.mli index 14049f7de2..7c4e82b14e 100644 --- a/lib/Migrate_ast.mli +++ b/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 diff --git a/lib/Translation_unit.ml b/lib/Translation_unit.ml index 11c4188b3b..896fa1f67b 100644 --- a/lib/Translation_unit.ml +++ b/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 diff --git a/test/passing/tests/doc_comments-no-wrap.mli.ref b/test/passing/tests/doc_comments-no-wrap.mli.ref index bf0cfed150..f00e96efab 100644 --- a/test/passing/tests/doc_comments-no-wrap.mli.ref +++ b/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 ) ]} *) (** {[ diff --git a/test/passing/tests/doc_comments.mli.ref b/test/passing/tests/doc_comments.mli.ref index 04cdb10d17..941f850838 100644 --- a/test/passing/tests/doc_comments.mli.ref +++ b/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 ) ]} *) (** {[ diff --git a/test/passing/tests/infix_arg_grouping.ml b/test/passing/tests/infix_arg_grouping.ml index bcf11e67fc..bbfa6862dd 100644 --- a/test/passing/tests/infix_arg_grouping.ml +++ b/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 diff --git a/test/unit/test_literal_lexer.ml b/test/unit/test_literal_lexer.ml index de43ede333..279fb5185c 100644 --- a/test/unit/test_literal_lexer.ml +++ b/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"