From eb3c8114ec30921cf96388e426c83a8100ab266f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 20 Sep 2023 11:59:41 +0200 Subject: [PATCH 01/10] Break multi-line strings in argument list Strings using the heavy syntax `{| ... |}` are always broken, string literals fitting on one line are not. --- lib/Ast.ml | 4 +++- lib/Migrate_ast.ml | 2 ++ lib/Migrate_ast.mli | 3 +++ test/passing/tests/doc_comments-no-wrap.mli.err | 14 +++++++------- test/passing/tests/doc_comments-no-wrap.mli.ref | 10 ++++++---- test/passing/tests/doc_comments.mli.err | 14 +++++++------- test/passing/tests/doc_comments.mli.ref | 10 ++++++---- test/unit/test_literal_lexer.ml | 8 +++++--- 8 files changed, 39 insertions(+), 26 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 522342075d..93505b4531 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -148,7 +148,9 @@ module Exp = struct let rec is_trivial exp = match exp.pexp_desc with - | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true + | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false + | Pexp_constant {pconst_desc= Pconst_string (_, loc, None); _} -> + Location.height loc = 1 | 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 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/test/passing/tests/doc_comments-no-wrap.mli.err b/test/passing/tests/doc_comments-no-wrap.mli.err index 49df9d7f4b..f54d9f48f1 100644 --- a/test/passing/tests/doc_comments-no-wrap.mli.err +++ b/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: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: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:624 exceeds the margin -Warning: tests/doc_comments.mli:645 exceeds the margin -Warning: tests/doc_comments.mli:658 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 diff --git a/test/passing/tests/doc_comments-no-wrap.mli.ref b/test/passing/tests/doc_comments-no-wrap.mli.ref index bf0cfed150..05d512e406 100644 --- a/test/passing/tests/doc_comments-no-wrap.mli.ref +++ b/test/passing/tests/doc_comments-no-wrap.mli.ref @@ -401,14 +401,16 @@ 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.err b/test/passing/tests/doc_comments.mli.err index db9ce31256..78e33d3ae2 100644 --- a/test/passing/tests/doc_comments.mli.err +++ b/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: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: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:618 exceeds the margin -Warning: tests/doc_comments.mli:639 exceeds the margin -Warning: tests/doc_comments.mli:652 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 diff --git a/test/passing/tests/doc_comments.mli.ref b/test/passing/tests/doc_comments.mli.ref index 04cdb10d17..de10b2803a 100644 --- a/test/passing/tests/doc_comments.mli.ref +++ b/test/passing/tests/doc_comments.mli.ref @@ -401,14 +401,16 @@ 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/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" From b017ee8015f5ab2700b97f676e718e8d7aee370d Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 20 Sep 2023 12:20:38 +0200 Subject: [PATCH 02/10] Some strings are trivial Short strings are common and the trivial property is used to format code like this in a compact way: Cmd.( v "git" % "clone" % "--depth" % "1" % "--branch" % branch % remote % p output_dir ) The rule is arbitrary and have not been confronted to the real world yet: - Length of 4 or less: always trivial - Length of 19 or less: trivial if made of only ASCII graphic characters --- lib/Ast.ml | 21 ++++++++++-- lib/Cmt.ml | 3 +- lib/Cmts.ml | 5 +-- lib/Conf.ml | 6 ++-- lib/Conf_decl.ml | 32 ++++++++++++------- lib/Docstring.ml | 3 +- lib/Fmt_ast.ml | 19 +++++++---- lib/Params.ml | 3 +- lib/Source.ml | 3 +- lib/Translation_unit.ml | 11 ++++--- test/passing/tests/args_grouped.ml | 9 ++++-- .../tests/break_infix-fit-or-vertical.ml.ref | 6 ++-- test/passing/tests/break_infix-wrap.ml.ref | 6 ++-- test/passing/tests/break_infix.ml.ref | 6 ++-- test/passing/tests/infix_arg_grouping.ml | 13 ++++---- test/passing/tests/issue77.ml | 3 +- test/passing/tests/source.ml.ref | 3 +- test/rpc/rpc_test.ml | 5 ++- test/rpc/rpc_test_fail.ml | 5 ++- test/unit/test_eol_compat.ml | 12 ++++--- test/unit/test_literal_lexer.ml | 5 +-- test/unit/test_translation_unit.ml | 6 ++-- 22 files changed, 124 insertions(+), 61 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 93505b4531..41444d0cd8 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -146,11 +146,21 @@ module Exp = struct false | _ -> List.exists pexp_attributes ~f:(Fn.non Attr.is_doc) + let is_string_const_trivial str = + let is_char_trivial = function + | ' ' | '\t' | '\n' | '\x00' .. '\x1f' | '\x7f' .. '\xff' -> false + | _ -> true + in + let len = String.length str in + len < 5 || (len < 20 && String.for_all ~f:is_char_trivial str) + let rec is_trivial exp = match exp.pexp_desc with + (* String literals using the heavy syntax are not trivial. *) | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false - | Pexp_constant {pconst_desc= Pconst_string (_, loc, None); _} -> - Location.height loc = 1 + (* Some short strings are trivial. *) + | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} -> + is_string_const_trivial str | 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 @@ -1516,7 +1526,12 @@ 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 (_, loc, None); _} -> + Location.height loc = 1 && fit_margin c (width xexp) + | Pexp_constant _ -> true | Pexp_field _ | Pexp_ident _ | Pexp_send _ |Pexp_construct (_, None) |Pexp_variant (_, None) -> diff --git a/lib/Cmt.ml b/lib/Cmt.ml index 5798f51f09..a66dbfe2e2 100644 --- a/lib/Cmt.ml +++ b/lib/Cmt.ml @@ -60,7 +60,8 @@ let pp_error fs {kind; cmt_kind} = in match kind with | `Added x -> - Format.fprintf fs "%!@{%a@}:@,@{Error@}: %s %a added.\n%!" + Format.fprintf fs + "%!@{%a@}:@,@{Error@}: %s %a added.\n%!" Location.print_loc (loc x) s_kind pp_cmt x | `Dropped x -> Format.fprintf fs diff --git a/lib/Cmts.ml b/lib/Cmts.ml index e39a1e57e7..0c4c8e8c0c 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -303,8 +303,9 @@ 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.ml b/lib/Conf.ml index 8f4f37bfa7..1e129652c5 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -39,7 +39,8 @@ let warn ~loc fmt = Format.kasprintf (fun s -> warn_raw - (Format.asprintf "%!@{%a@}:@,@{Warning@}: %s\n%!" + (Format.asprintf + "%!@{%a@}:@,@{Warning@}: %s\n%!" Location.print_loc loc s ) ) fmt @@ -866,7 +867,8 @@ 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." ] diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml index e5b6c24eb3..d669790ec8 100644 --- a/lib/Conf_decl.ml +++ b/lib/Conf_decl.ml @@ -163,11 +163,13 @@ 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 @@ -187,8 +189,9 @@ 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 +211,9 @@ 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 +222,9 @@ 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 +332,14 @@ 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 +368,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/Docstring.ml b/lib/Docstring.ml index 5b070302b2..d7a01a8076 100644 --- a/lib/Docstring.ml +++ b/lib/Docstring.ml @@ -26,7 +26,8 @@ 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 = diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d39a838cfb..497cd498a1 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -3656,7 +3656,9 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = pro= Some ( Cmts.fmt_before c pmty_loc - $ fmt_if parens "(" $ str "module type of " $ pro ) + $ fmt_if parens "(" + $ str "module type of " + $ pro ) ; epi= Some epi } | _ -> { blk with @@ -4011,14 +4013,17 @@ and fmt_with_constraint c ctx ~pre = function | Pwith_type (lid, td) -> fmt_type_declaration ~pre:(pre ^ " type") c ~name:lid (sub_td ~ctx td) | Pwith_module (m1, m2) -> - str pre $ str " module " $ fmt_longident_loc c m1 $ str " = " - $ fmt_longident_loc c m2 + str pre + $ str " module " + $ fmt_longident_loc c m1 $ str " = " $ fmt_longident_loc c m2 | Pwith_typesubst (lid, td) -> - fmt_type_declaration ~pre:(pre ^ " type") c ~eq:":=" ~name:lid - (sub_td ~ctx td) + fmt_type_declaration + ~pre:(pre ^ " type") + c ~eq:":=" ~name:lid (sub_td ~ctx td) | Pwith_modsubst (m1, m2) -> - str pre $ str " module " $ fmt_longident_loc c m1 $ str " := " - $ fmt_longident_loc c m2 + str pre + $ str " module " + $ fmt_longident_loc c m1 $ str " := " $ fmt_longident_loc c m2 | Pwith_modtype (m1, m2) -> let m1 = {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in diff --git a/lib/Params.ml b/lib/Params.ml index 256516f272..9b89031bf6 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -409,7 +409,8 @@ let collection_expr (c : Conf.t) ~space_around opn cls = else box_collec c 0 (wrap_collec c ~space_around opn cls k) ) ; sep_before= noop ; sep_after_non_final= - fmt_or_k dock (fmt ";@;<1 0>") + fmt_or_k dock + (fmt ";@;<1 0>") (char ';' $ break 1 (String.length opn + 1)) ; sep_after_final= fmt_if_k dock (fits_breaks ~level:1 "" ";") } diff --git a/lib/Source.ml b/lib/Source.ml index bb234a292d..3b610d71f0 100644 --- a/lib/Source.ml +++ b/lib/Source.ml @@ -105,7 +105,8 @@ 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) = diff --git a/lib/Translation_unit.ml b/lib/Translation_unit.ml index 11c4188b3b..aeb523cba9 100644 --- a/lib/Translation_unit.ml +++ b/lib/Translation_unit.ml @@ -59,7 +59,9 @@ 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 +119,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 +185,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/args_grouped.ml b/test/passing/tests/args_grouped.ml index 557710a46a..f702fdd993 100644 --- a/test/passing/tests/args_grouped.ml +++ b/test/passing/tests/args_grouped.ml @@ -43,7 +43,8 @@ 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 ) @@ -80,14 +81,16 @@ 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 diff --git a/test/passing/tests/break_infix-fit-or-vertical.ml.ref b/test/passing/tests/break_infix-fit-or-vertical.ml.ref index 7aa7824b43..7ffc4959e0 100644 --- a/test/passing/tests/break_infix-fit-or-vertical.ml.ref +++ b/test/passing/tests/break_infix-fit-or-vertical.ml.ref @@ -108,7 +108,8 @@ 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) @@ -123,7 +124,8 @@ 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) diff --git a/test/passing/tests/break_infix-wrap.ml.ref b/test/passing/tests/break_infix-wrap.ml.ref index 3b2545994f..7ece143509 100644 --- a/test/passing/tests/break_infix-wrap.ml.ref +++ b/test/passing/tests/break_infix-wrap.ml.ref @@ -65,7 +65,8 @@ 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) @@ -80,7 +81,8 @@ 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) diff --git a/test/passing/tests/break_infix.ml.ref b/test/passing/tests/break_infix.ml.ref index 71a79f5806..f81a90c656 100644 --- a/test/passing/tests/break_infix.ml.ref +++ b/test/passing/tests/break_infix.ml.ref @@ -97,7 +97,8 @@ 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) @@ -112,7 +113,8 @@ 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) diff --git a/test/passing/tests/infix_arg_grouping.ml b/test/passing/tests/infix_arg_grouping.ml index bcf11e67fc..170b342d51 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 @@ -57,10 +57,11 @@ hvbox 0 $ wrap "(" ")" ( str txt $ opt mt (fun _ -> - fmt "@ : " $ Option.call ~f:pro_t $ psp_t $ fmt "@;<1 2>" $ bdy_t - $ esp_t $ Option.call ~f:epi_t ) ) - $ fmt " ->@ " $ Option.call ~f:pro_e $ psp_e $ bdy_e $ esp_e - $ Option.call ~f:epi_e ) + fmt "@ : " $ Option.call ~f:pro_t $ psp_t + $ fmt "@;<1 2>" + $ bdy_t $ esp_t $ Option.call ~f:epi_t ) ) + $ fmt " ->@ " + $ Option.call ~f:pro_e $ psp_e $ bdy_e $ esp_e $ Option.call ~f:epi_e ) let to_json {integers; floats; strings} = `Assoc diff --git a/test/passing/tests/issue77.ml b/test/passing/tests/issue77.ml index 33348811c5..668c08e25a 100644 --- a/test/passing/tests/issue77.ml +++ b/test/passing/tests/issue77.ml @@ -2,7 +2,8 @@ let div = [ div ~a: [ Reactive.a_style - (React.S.map (sprintf "height: %dpx") + (React.S.map + (sprintf "height: %dpx") (State.player_height_signal app_state) ) (* ksprintf a_style "%s" (if_smth "min-height: 300px;" ""); *) ] content ] diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index a9ed012b4d..26a84f57dc 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9188,7 +9188,8 @@ 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 *) diff --git a/test/rpc/rpc_test.ml b/test/rpc/rpc_test.ml index 3908b9b679..2b8688e12e 100644 --- a/test/rpc/rpc_test.ml +++ b/test/rpc/rpc_test.ml @@ -100,7 +100,10 @@ let close_client () = | Errored -> () let config c = - get_client () >>= fun cl -> log "[ocf] Config\n%!" ; Ocf.config c cl + get_client () + >>= fun cl -> + log "[ocf] Config\n%!" ; + Ocf.config c cl let format ?(format_args = empty_args) ?versions x = get_client ?versions () diff --git a/test/rpc/rpc_test_fail.ml b/test/rpc/rpc_test_fail.ml index 63840944cf..8da5ea103d 100644 --- a/test/rpc/rpc_test_fail.ml +++ b/test/rpc/rpc_test_fail.ml @@ -98,7 +98,10 @@ let close_client () = | Errored -> () let config c = - get_client () >>= fun cl -> log "[ocf] Config\n%!" ; Ocf.config c cl + get_client () + >>= fun cl -> + log "[ocf] Config\n%!" ; + Ocf.config c cl let format x = get_client () diff --git a/test/unit/test_eol_compat.ml b/test/unit/test_eol_compat.ml index 159ca16626..7190554147 100644 --- a/test/unit/test_eol_compat.ml +++ b/test/unit/test_eol_compat.ml @@ -34,22 +34,26 @@ 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" diff --git a/test/unit/test_literal_lexer.ml b/test/unit/test_literal_lexer.ml index 279fb5185c..99a307dc63 100644 --- a/test/unit/test_literal_lexer.ml +++ b/test/unit/test_literal_lexer.ml @@ -25,8 +25,9 @@ let tests_string = in let test name s ~expected_preserve ~expected_normalize = [ test_one (name ^ " (preserve)") s `Preserve ~expected:expected_preserve - ; test_one (name ^ " (normalize)") s `Normalize - ~expected:expected_normalize ] + ; test_one + (name ^ " (normalize)") + s `Normalize ~expected:expected_normalize ] in List.concat [ [test_opt "string: not a string" {|hello|} `Preserve ~expected:None] diff --git a/test/unit/test_translation_unit.ml b/test/unit/test_translation_unit.ml index 8ed115e5fe..12f24d4fa7 100644 --- a/test/unit/test_translation_unit.ml +++ b/test/unit/test_translation_unit.ml @@ -33,7 +33,8 @@ 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: @@ -115,7 +116,8 @@ File "", 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 = From feafdf9fbb55cf35a6f3b350df96905383e5b0cf Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 20 Sep 2023 12:24:45 +0200 Subject: [PATCH 03/10] Remove hopefully unecessary expression size simulation --- lib/Fmt_ast.ml | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 497cd498a1..1ea09d6022 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1516,18 +1516,9 @@ 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 break x y = Cmts.has_after c.cmts (snd x).pexp_loc || not (is_simple x && is_simple y) From 93d5049f229a9d2735d601a9f5d3ca194304b247 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 20 Sep 2023 12:41:28 +0200 Subject: [PATCH 04/10] Trivial is simple --- lib/Ast.ml | 2 +- test/passing/tests/js_args.ml.ref | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 41444d0cd8..b81574283b 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1530,7 +1530,7 @@ 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); _} -> - 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) diff --git a/test/passing/tests/js_args.ml.ref b/test/passing/tests/js_args.ml.ref index 848baca151..5d7a5d5e3b 100644 --- a/test/passing/tests/js_args.ml.ref +++ b/test/passing/tests/js_args.ml.ref @@ -33,8 +33,7 @@ let () = messages := Message_store.create (Session_id.of_string "") (* Tuareg indents these lines too far to the left. *) - "herd-retransmitter" - Message_store.Message_size.Byte + "herd-retransmitter" Message_store.Message_size.Byte let () = raise From b7ef60002a5588d09c018674d5a360a9c684d744 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 22 Sep 2023 14:58:46 +0200 Subject: [PATCH 05/10] 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 | 3 ++- lib/Cmt.ml | 3 +-- lib/Cmts.ml | 3 +-- lib/Conf.ml | 6 ++---- lib/Conf_decl.ml | 18 ++++++------------ lib/Docstring.ml | 3 +-- lib/Fmt_ast.ml | 12 +++++++++++- lib/Source.ml | 3 +-- lib/Translation_unit.ml | 3 +-- test/passing/tests/args_grouped.ml | 9 +++------ .../tests/break_infix-fit-or-vertical.ml.ref | 6 ++---- test/passing/tests/break_infix-wrap.ml.ref | 6 ++---- test/passing/tests/break_infix.ml.ref | 6 ++---- .../passing/tests/doc_comments-no-wrap.mli.err | 14 +++++++------- .../passing/tests/doc_comments-no-wrap.mli.ref | 6 ++---- test/passing/tests/doc_comments.mli.err | 14 +++++++------- test/passing/tests/doc_comments.mli.ref | 6 ++---- test/passing/tests/source.ml.ref | 3 +-- test/unit/test_eol_compat.ml | 12 ++++-------- test/unit/test_translation_unit.ml | 6 ++---- 20 files changed, 60 insertions(+), 82 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index b81574283b..1645c24dac 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1530,7 +1530,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) diff --git a/lib/Cmt.ml b/lib/Cmt.ml index a66dbfe2e2..5798f51f09 100644 --- a/lib/Cmt.ml +++ b/lib/Cmt.ml @@ -60,8 +60,7 @@ let pp_error fs {kind; cmt_kind} = in match kind with | `Added x -> - Format.fprintf fs - "%!@{%a@}:@,@{Error@}: %s %a added.\n%!" + Format.fprintf fs "%!@{%a@}:@,@{Error@}: %s %a added.\n%!" Location.print_loc (loc x) s_kind pp_cmt x | `Dropped x -> Format.fprintf fs diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 0c4c8e8c0c..5527b322d5 100644 --- a/lib/Cmts.ml +++ b/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 diff --git a/lib/Conf.ml b/lib/Conf.ml index 1e129652c5..8f4f37bfa7 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -39,8 +39,7 @@ let warn ~loc fmt = Format.kasprintf (fun s -> warn_raw - (Format.asprintf - "%!@{%a@}:@,@{Warning@}: %s\n%!" + (Format.asprintf "%!@{%a@}:@,@{Warning@}: %s\n%!" Location.print_loc loc s ) ) fmt @@ -867,8 +866,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." ] diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml index d669790ec8..9cf3379529 100644 --- a/lib/Conf_decl.ml +++ b/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} = diff --git a/lib/Docstring.ml b/lib/Docstring.ml index d7a01a8076..5b070302b2 100644 --- a/lib/Docstring.ml +++ b/lib/Docstring.ml @@ -26,8 +26,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 = diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 1ea09d6022..8b8edfbe2e 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1520,8 +1520,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 diff --git a/lib/Source.ml b/lib/Source.ml index 3b610d71f0..bb234a292d 100644 --- a/lib/Source.ml +++ b/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) = diff --git a/lib/Translation_unit.ml b/lib/Translation_unit.ml index aeb523cba9..896fa1f67b 100644 --- a/lib/Translation_unit.ml +++ b/lib/Translation_unit.ml @@ -59,8 +59,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 diff --git a/test/passing/tests/args_grouped.ml b/test/passing/tests/args_grouped.ml index f702fdd993..557710a46a 100644 --- a/test/passing/tests/args_grouped.ml +++ b/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 diff --git a/test/passing/tests/break_infix-fit-or-vertical.ml.ref b/test/passing/tests/break_infix-fit-or-vertical.ml.ref index 7ffc4959e0..7aa7824b43 100644 --- a/test/passing/tests/break_infix-fit-or-vertical.ml.ref +++ b/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) diff --git a/test/passing/tests/break_infix-wrap.ml.ref b/test/passing/tests/break_infix-wrap.ml.ref index 7ece143509..3b2545994f 100644 --- a/test/passing/tests/break_infix-wrap.ml.ref +++ b/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) diff --git a/test/passing/tests/break_infix.ml.ref b/test/passing/tests/break_infix.ml.ref index f81a90c656..71a79f5806 100644 --- a/test/passing/tests/break_infix.ml.ref +++ b/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) diff --git a/test/passing/tests/doc_comments-no-wrap.mli.err b/test/passing/tests/doc_comments-no-wrap.mli.err index f54d9f48f1..49df9d7f4b 100644 --- a/test/passing/tests/doc_comments-no-wrap.mli.err +++ b/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 diff --git a/test/passing/tests/doc_comments-no-wrap.mli.ref b/test/passing/tests/doc_comments-no-wrap.mli.ref index 05d512e406..f00e96efab 100644 --- a/test/passing/tests/doc_comments-no-wrap.mli.ref +++ b/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 ) ]} *) diff --git a/test/passing/tests/doc_comments.mli.err b/test/passing/tests/doc_comments.mli.err index 78e33d3ae2..db9ce31256 100644 --- a/test/passing/tests/doc_comments.mli.err +++ b/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 diff --git a/test/passing/tests/doc_comments.mli.ref b/test/passing/tests/doc_comments.mli.ref index de10b2803a..941f850838 100644 --- a/test/passing/tests/doc_comments.mli.ref +++ b/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 ) ]} *) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 26a84f57dc..a9ed012b4d 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -9188,8 +9188,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 *) diff --git a/test/unit/test_eol_compat.ml b/test/unit/test_eol_compat.ml index 7190554147..159ca16626 100644 --- a/test/unit/test_eol_compat.ml +++ b/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" diff --git a/test/unit/test_translation_unit.ml b/test/unit/test_translation_unit.ml index 12f24d4fa7..8ed115e5fe 100644 --- a/test/unit/test_translation_unit.ml +++ b/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 "", 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 = From 40a6b38fbab779918fff219f36ee231b8e2c46c0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 22 Sep 2023 15:47:53 +0200 Subject: [PATCH 06/10] More permissive is_trivial for strings String of a length less than 30 are trivial. This is still more restrictive than on main. --- lib/Ast.ml | 12 ++---------- lib/Cmts.ml | 4 ++-- lib/Conf_decl.ml | 4 ++-- lib/Fmt_ast.ml | 19 +++++++------------ lib/Params.ml | 3 +-- test/passing/tests/infix_arg_grouping.ml | 9 ++++----- test/passing/tests/issue77.ml | 3 +-- test/rpc/rpc_test.ml | 5 +---- test/rpc/rpc_test_fail.ml | 5 +---- test/unit/test_literal_lexer.ml | 5 ++--- 10 files changed, 23 insertions(+), 46 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 1645c24dac..7c717b535e 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -146,21 +146,13 @@ module Exp = struct false | _ -> List.exists pexp_attributes ~f:(Fn.non Attr.is_doc) - let is_string_const_trivial str = - let is_char_trivial = function - | ' ' | '\t' | '\n' | '\x00' .. '\x1f' | '\x7f' .. '\xff' -> false - | _ -> true - in - let len = String.length str in - len < 5 || (len < 20 && String.for_all ~f:is_char_trivial str) - let rec is_trivial exp = match exp.pexp_desc with (* String literals using the heavy syntax are not trivial. *) | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false - (* Some short strings are trivial. *) + (* Short strings are trivial. *) | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} -> - is_string_const_trivial str + 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 diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 5527b322d5..e39a1e57e7 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 9cf3379529..70499e42fd 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 "" diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 8b8edfbe2e..2df703cdf6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -3657,9 +3657,7 @@ and fmt_module_type c ?(rec_ = false) ({ast= mty; _} as xmty) = pro= Some ( Cmts.fmt_before c pmty_loc - $ fmt_if parens "(" - $ str "module type of " - $ pro ) + $ fmt_if parens "(" $ str "module type of " $ pro ) ; epi= Some epi } | _ -> { blk with @@ -4014,17 +4012,14 @@ and fmt_with_constraint c ctx ~pre = function | Pwith_type (lid, td) -> fmt_type_declaration ~pre:(pre ^ " type") c ~name:lid (sub_td ~ctx td) | Pwith_module (m1, m2) -> - str pre - $ str " module " - $ fmt_longident_loc c m1 $ str " = " $ fmt_longident_loc c m2 + str pre $ str " module " $ fmt_longident_loc c m1 $ str " = " + $ fmt_longident_loc c m2 | Pwith_typesubst (lid, td) -> - fmt_type_declaration - ~pre:(pre ^ " type") - c ~eq:":=" ~name:lid (sub_td ~ctx td) + fmt_type_declaration ~pre:(pre ^ " type") c ~eq:":=" ~name:lid + (sub_td ~ctx td) | Pwith_modsubst (m1, m2) -> - str pre - $ str " module " - $ fmt_longident_loc c m1 $ str " := " $ fmt_longident_loc c m2 + str pre $ str " module " $ fmt_longident_loc c m1 $ str " := " + $ fmt_longident_loc c m2 | Pwith_modtype (m1, m2) -> let m1 = {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in diff --git a/lib/Params.ml b/lib/Params.ml index 9b89031bf6..256516f272 100644 --- a/lib/Params.ml +++ b/lib/Params.ml @@ -409,8 +409,7 @@ let collection_expr (c : Conf.t) ~space_around opn cls = else box_collec c 0 (wrap_collec c ~space_around opn cls k) ) ; sep_before= noop ; sep_after_non_final= - fmt_or_k dock - (fmt ";@;<1 0>") + fmt_or_k dock (fmt ";@;<1 0>") (char ';' $ break 1 (String.length opn + 1)) ; sep_after_final= fmt_if_k dock (fits_breaks ~level:1 "" ";") } diff --git a/test/passing/tests/infix_arg_grouping.ml b/test/passing/tests/infix_arg_grouping.ml index 170b342d51..bbfa6862dd 100644 --- a/test/passing/tests/infix_arg_grouping.ml +++ b/test/passing/tests/infix_arg_grouping.ml @@ -57,11 +57,10 @@ hvbox 0 $ wrap "(" ")" ( str txt $ opt mt (fun _ -> - fmt "@ : " $ Option.call ~f:pro_t $ psp_t - $ fmt "@;<1 2>" - $ bdy_t $ esp_t $ Option.call ~f:epi_t ) ) - $ fmt " ->@ " - $ Option.call ~f:pro_e $ psp_e $ bdy_e $ esp_e $ Option.call ~f:epi_e ) + fmt "@ : " $ Option.call ~f:pro_t $ psp_t $ fmt "@;<1 2>" $ bdy_t + $ esp_t $ Option.call ~f:epi_t ) ) + $ fmt " ->@ " $ Option.call ~f:pro_e $ psp_e $ bdy_e $ esp_e + $ Option.call ~f:epi_e ) let to_json {integers; floats; strings} = `Assoc diff --git a/test/passing/tests/issue77.ml b/test/passing/tests/issue77.ml index 668c08e25a..33348811c5 100644 --- a/test/passing/tests/issue77.ml +++ b/test/passing/tests/issue77.ml @@ -2,8 +2,7 @@ let div = [ div ~a: [ Reactive.a_style - (React.S.map - (sprintf "height: %dpx") + (React.S.map (sprintf "height: %dpx") (State.player_height_signal app_state) ) (* ksprintf a_style "%s" (if_smth "min-height: 300px;" ""); *) ] content ] diff --git a/test/rpc/rpc_test.ml b/test/rpc/rpc_test.ml index 2b8688e12e..3908b9b679 100644 --- a/test/rpc/rpc_test.ml +++ b/test/rpc/rpc_test.ml @@ -100,10 +100,7 @@ let close_client () = | Errored -> () let config c = - get_client () - >>= fun cl -> - log "[ocf] Config\n%!" ; - Ocf.config c cl + get_client () >>= fun cl -> log "[ocf] Config\n%!" ; Ocf.config c cl let format ?(format_args = empty_args) ?versions x = get_client ?versions () diff --git a/test/rpc/rpc_test_fail.ml b/test/rpc/rpc_test_fail.ml index 8da5ea103d..63840944cf 100644 --- a/test/rpc/rpc_test_fail.ml +++ b/test/rpc/rpc_test_fail.ml @@ -98,10 +98,7 @@ let close_client () = | Errored -> () let config c = - get_client () - >>= fun cl -> - log "[ocf] Config\n%!" ; - Ocf.config c cl + get_client () >>= fun cl -> log "[ocf] Config\n%!" ; Ocf.config c cl let format x = get_client () diff --git a/test/unit/test_literal_lexer.ml b/test/unit/test_literal_lexer.ml index 99a307dc63..279fb5185c 100644 --- a/test/unit/test_literal_lexer.ml +++ b/test/unit/test_literal_lexer.ml @@ -25,9 +25,8 @@ let tests_string = in let test name s ~expected_preserve ~expected_normalize = [ test_one (name ^ " (preserve)") s `Preserve ~expected:expected_preserve - ; test_one - (name ^ " (normalize)") - s `Normalize ~expected:expected_normalize ] + ; test_one (name ^ " (normalize)") s `Normalize + ~expected:expected_normalize ] in List.concat [ [test_opt "string: not a string" {|hello|} `Preserve ~expected:None] From 8deba41669d403d9eb44cbd2876f1ab5f4969bee Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 2 Oct 2023 17:01:31 +0200 Subject: [PATCH 07/10] Strings of length < 80 are trivial and simple --- lib/Ast.ml | 10 ++-------- lib/Conf_decl.ml | 18 ++++++++---------- lib/Translation_unit.ml | 10 ++++------ lib/box_debug.ml | 3 +-- .../passing/tests/doc_comments-no-wrap.mli.ref | 8 ++++---- test/passing/tests/doc_comments.mli.ref | 8 ++++---- test/passing/tests/infix_arg_grouping.ml | 4 ++-- test/rpc/rpc_test.ml | 3 +-- test/rpc/rpc_test_fail.ml | 3 +-- 9 files changed, 27 insertions(+), 40 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 7c717b535e..500784a74a 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -152,7 +152,7 @@ module Exp = struct | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false (* Short strings are trivial. *) | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} -> - String.length str < 30 + String.length str < 80 | 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 @@ -1518,13 +1518,7 @@ end = struct let rec is_simple (c : Conf.t) width ({ast= exp; _} as xexp) = let ctx = Exp exp in match exp.pexp_desc with - (* 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 (_, loc, None); _} -> - Exp.is_trivial exp - || (Location.height loc = 1 && fit_margin c (width xexp)) - | Pexp_constant _ -> true + | Pexp_constant _ -> Exp.is_trivial exp | Pexp_field _ | Pexp_ident _ | Pexp_send _ |Pexp_construct (_, None) |Pexp_variant (_, None) -> diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml index 70499e42fd..e5b6c24eb3 100644 --- a/lib/Conf_decl.ml +++ b/lib/Conf_decl.ml @@ -208,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" - doc default + Format.asprintf "%s The flag is $(b,%s) by default.%s%a" doc default (in_attributes allow_inline kind) status_doc status @@ -218,8 +217,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" - doc default + Format.asprintf "%s The default value is $(b,%s).%s%a" doc default (in_attributes allow_inline kind) status_doc status @@ -327,13 +325,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 -> () @@ -362,8 +360,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/Translation_unit.ml b/lib/Translation_unit.ml index 896fa1f67b..11c4188b3b 100644 --- a/lib/Translation_unit.ml +++ b/lib/Translation_unit.ml @@ -59,8 +59,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" - 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 @@ -118,8 +117,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\ @@ -184,8 +183,7 @@ 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/lib/box_debug.ml b/lib/box_debug.ml index f76d968183..62a10c7ac3 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -101,8 +101,7 @@ let break fs n o = if !debug then fprintf fs "
(%i,%i)break %i \ - %i
" - n o n o + %i" n o n o let pp_keyword fs s = fprintf fs "%s" s diff --git a/test/passing/tests/doc_comments-no-wrap.mli.ref b/test/passing/tests/doc_comments-no-wrap.mli.ref index f00e96efab..bf0cfed150 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 941f850838..04cdb10d17 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 bbfa6862dd..bcf11e67fc 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/rpc/rpc_test.ml b/test/rpc/rpc_test.ml index 3908b9b679..3a75868ac8 100644 --- a/test/rpc/rpc_test.ml +++ b/test/rpc/rpc_test.ml @@ -79,8 +79,7 @@ let start ?versions () = log "An error occured while initializing and configuring ocamlformat:\n\ %s\n\ - %!" - msg ; + %!" msg ; `No_process ) let get_client ?versions () = diff --git a/test/rpc/rpc_test_fail.ml b/test/rpc/rpc_test_fail.ml index 63840944cf..d57146ea00 100644 --- a/test/rpc/rpc_test_fail.ml +++ b/test/rpc/rpc_test_fail.ml @@ -77,8 +77,7 @@ let start () = log "An error occured while initializing and configuring ocamlformat:\n\ %s\n\ - %!" - msg ; + %!" msg ; `No_process ) let get_client () = From 27c6f246b3d867de0ace2f11880c09c99e39a5e0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 3 Oct 2023 11:59:34 +0200 Subject: [PATCH 08/10] Revert "Strings of length < 80 are trivial and simple" This reverts commit 55ebbe5e063fe7cdd13e32dbd7676fdd69fa1c75. --- lib/Ast.ml | 10 ++++++++-- lib/Conf_decl.ml | 18 ++++++++++-------- lib/Translation_unit.ml | 10 ++++++---- lib/box_debug.ml | 3 ++- .../passing/tests/doc_comments-no-wrap.mli.ref | 8 ++++---- test/passing/tests/doc_comments.mli.ref | 8 ++++---- test/passing/tests/infix_arg_grouping.ml | 4 ++-- test/rpc/rpc_test.ml | 3 ++- test/rpc/rpc_test_fail.ml | 3 ++- 9 files changed, 40 insertions(+), 27 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 500784a74a..7c717b535e 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -152,7 +152,7 @@ module Exp = struct | Pexp_constant {pconst_desc= Pconst_string (_, _, Some _); _} -> false (* Short strings are trivial. *) | Pexp_constant {pconst_desc= Pconst_string (str, _, None); _} -> - String.length str < 80 + 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 @@ -1518,7 +1518,13 @@ 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 (_, loc, None); _} -> + 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) |Pexp_variant (_, None) -> diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml index e5b6c24eb3..70499e42fd 100644 --- a/lib/Conf_decl.ml +++ b/lib/Conf_decl.ml @@ -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/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/lib/box_debug.ml b/lib/box_debug.ml index 62a10c7ac3..f76d968183 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -101,7 +101,8 @@ let break fs n o = if !debug then fprintf fs "
(%i,%i)break %i \ - %i
" n o n o + %i" + n o n o let pp_keyword fs s = fprintf fs "%s" s 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/rpc/rpc_test.ml b/test/rpc/rpc_test.ml index 3a75868ac8..3908b9b679 100644 --- a/test/rpc/rpc_test.ml +++ b/test/rpc/rpc_test.ml @@ -79,7 +79,8 @@ let start ?versions () = log "An error occured while initializing and configuring ocamlformat:\n\ %s\n\ - %!" msg ; + %!" + msg ; `No_process ) let get_client ?versions () = diff --git a/test/rpc/rpc_test_fail.ml b/test/rpc/rpc_test_fail.ml index d57146ea00..63840944cf 100644 --- a/test/rpc/rpc_test_fail.ml +++ b/test/rpc/rpc_test_fail.ml @@ -77,7 +77,8 @@ let start () = log "An error occured while initializing and configuring ocamlformat:\n\ %s\n\ - %!" msg ; + %!" + msg ; `No_process ) let get_client () = From 9fa3287c8d59259bc613d99c642354ac435f83e7 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 22 Jan 2024 13:51:48 +0100 Subject: [PATCH 09/10] fmt --- test/passing/tests/infix_arg_grouping.ml.ref | 4 ++-- test/passing/tests/js_args.ml.ref | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/test/passing/tests/infix_arg_grouping.ml.ref b/test/passing/tests/infix_arg_grouping.ml.ref index aa71b47d83..74ad1fcac4 100644 --- a/test/passing/tests/infix_arg_grouping.ml.ref +++ b/test/passing/tests/infix_arg_grouping.ml.ref @@ -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/passing/tests/js_args.ml.ref b/test/passing/tests/js_args.ml.ref index 5d7a5d5e3b..848baca151 100644 --- a/test/passing/tests/js_args.ml.ref +++ b/test/passing/tests/js_args.ml.ref @@ -33,7 +33,8 @@ let () = messages := Message_store.create (Session_id.of_string "") (* Tuareg indents these lines too far to the left. *) - "herd-retransmitter" Message_store.Message_size.Byte + "herd-retransmitter" + Message_store.Message_size.Byte let () = raise From 09513e06bb6273297d30d9cda6735ecb7b7e13e0 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 22 Jan 2024 14:26:43 +0100 Subject: [PATCH 10/10] Improve a bit the break rules --- lib/Ast.ml | 4 +--- lib/Cmts.ml | 4 ++-- lib/Conf_decl.ml | 4 ++-- lib/Fmt_ast.ml | 7 ++++--- test/passing/tests/infix_arg_grouping.ml.ref | 4 ++-- 5 files changed, 11 insertions(+), 12 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 7c717b535e..06af05cbb8 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1521,9 +1521,7 @@ end = struct (* 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 (_, loc, None); _} -> - Exp.is_trivial exp - || (Location.height loc = 1 && fit_margin c (width xexp)) + | Pexp_constant {pconst_desc= Pconst_string (_, _, None); _} -> true | Pexp_constant _ -> true | Pexp_field _ | Pexp_ident _ | Pexp_send _ |Pexp_construct (_, 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 70499e42fd..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 "" diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 2df703cdf6..140a121724 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1520,13 +1520,14 @@ 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) = + 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 (_, _, None); _} -> false + | 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 = diff --git a/test/passing/tests/infix_arg_grouping.ml.ref b/test/passing/tests/infix_arg_grouping.ml.ref index 74ad1fcac4..aa71b47d83 100644 --- a/test/passing/tests/infix_arg_grouping.ml.ref +++ b/test/passing/tests/infix_arg_grouping.ml.ref @@ -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