From 1cd9882a30a38e2c60d3bbdd0f88069df8c412ce Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Thu, 16 Oct 2025 13:06:24 +0200 Subject: [PATCH 1/2] Added test showcasing the lack of RPC warning on missing promotion target Signed-off-by: Ambre Austen Suhamy --- .../test-cases/watching/promotion-db.t | 70 +++++++++++++++++++ 1 file changed, 70 insertions(+) create mode 100644 test/blackbox-tests/test-cases/watching/promotion-db.t diff --git a/test/blackbox-tests/test-cases/watching/promotion-db.t b/test/blackbox-tests/test-cases/watching/promotion-db.t new file mode 100644 index 00000000000..11b6ca0079d --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/promotion-db.t @@ -0,0 +1,70 @@ +Demonstrate bug where the RPC promotion doesn't print a warning where the normal promotion does. + + $ . ./helpers.sh + + $ echo '(lang dune 3.20)' > dune-project + +Something to promote for a + $ echo " $ echo hello" > a.t + +Nothing to promote for b + $ cat > b.t << EOF + > $ echo hello + > hello + > EOF + +Something to promote for c, but we don't care for it right now. + $ echo " $ echo hello" > c.t + +Promoting a at this point does nothing, and we print a warning. + $ dune promote a.t + Warning: Nothing to promote for a.t. + + $ start_dune + $ dune rpc ping --wait + Server appears to be responding normally + +This should be a warning for a and b. + $ dune promote a.t b.t + Success + +Now a is in the promotion database, + $ build "(alias a)" + Failure + +and c as well. + $ build "(alias c)" + Failure + +This should be a success for a (and print nothing), and a warning for b. + $ dune promote a.t b.t + Success + +This is incorrect! + $ cat a.t + $ echo hello + + $ cat b.t + $ echo hello + hello + +C should still be in the database at this point, and promotion should work. + $ dune promote c.t + Success + + $ cat c.t + $ echo hello + hello + + $ stop_dune + Warning: Nothing to promote for a.t. + Warning: Nothing to promote for b.t. + File "a.t", line 1, characters 0-0: + Error: Files _build/default/a.t and _build/default/a.t.corrected differ. + Had 1 error, waiting for filesystem changes... + File "c.t", line 1, characters 0-0: + Error: Files _build/default/c.t and _build/default/c.t.corrected differ. + Had 1 error, waiting for filesystem changes... + Warning: Nothing to promote for a.t. + Warning: Nothing to promote for b.t. + Promoting _build/default/c.t.corrected to c.t. From 80eb60339c32a70367025220beb22e37b1b7eede Mon Sep 17 00:00:00 2001 From: Ambre Austen Suhamy Date: Mon, 20 Oct 2025 17:29:12 +0200 Subject: [PATCH 2/2] Fix promotion not having warnings Signed-off-by: Ambre Austen Suhamy --- bin/promotion.ml | 65 +++--- bin/rpc/rpc_common.ml | 49 +++- otherlibs/dune-rpc/private/exported_types.ml | 49 ++-- otherlibs/dune-rpc/private/exported_types.mli | 23 +- src/dune_rpc_impl/diagnostics.ml | 9 +- src/dune_rpc_impl/server.ml | 35 ++- src/promote/diff_promotion.ml | 144 ++++++++---- src/promote/diff_promotion.mli | 29 ++- .../test-cases/promote/promotion-show.t | 2 +- .../test-cases/watching/promotion-db.t | 70 ------ .../test-cases/watching/warnings.t | 47 ++++ .../dune_rpc_e2e/dune_rpc_diagnostics.ml | 211 ++++++++++-------- 12 files changed, 438 insertions(+), 295 deletions(-) delete mode 100644 test/blackbox-tests/test-cases/watching/promotion-db.t create mode 100644 test/blackbox-tests/test-cases/watching/warnings.t diff --git a/bin/promotion.ml b/bin/promotion.ml index 52880846ead..86e55b3f258 100644 --- a/bin/promotion.ml +++ b/bin/promotion.ml @@ -8,44 +8,14 @@ let files_to_promote ~common files : Dune_rpc.Files_to_promote.t = let files = List.map files ~f:(fun fn -> Path.Source.of_string (Common.prefix_target common fn)) in - let on_missing fn = - User_warning.emit - [ Pp.textf "Nothing to promote for %s." (Path.Source.to_string_maybe_quoted fn) ] - in - These (files, on_missing) -;; - -let display_files files_to_promote = - let open Fiber.O in - Diff_promotion.load_db () - |> Diff_promotion.filter_db files_to_promote - |> Fiber.parallel_map ~f:(fun file -> - Diff_promotion.diff_for_file file - >>| function - | Ok _ -> Some file - | Error _ -> None) - >>| List.filter_opt - >>| List.sort ~compare:(fun file file' -> Diff_promotion.File.compare file file') - >>| List.iter ~f:(fun (file : Diff_promotion.File.t) -> - Console.printf "%s" (Diff_promotion.File.source file |> Path.Source.to_string)) + These files ;; -let show_corrected_contents files_to_promote = - let open Fiber.O in - let files = Diff_promotion.load_db () |> Diff_promotion.filter_db files_to_promote in - let+ () = Fiber.return () in - List.iter files ~f:(fun file -> - let correction_file = Diff_promotion.File.correction_file file in - if Path.exists correction_file - then ( - let contents = Io.read_file correction_file in - Console.printf "%s" contents) - else - User_warning.emit - [ Pp.textf - "Corrected file does not exist for %s." - (Diff_promotion.File.source file |> Path.Source.to_string_maybe_quoted) - ]) +let on_missing fn = + User_warning.emit + [ Pp.paragraphf "Nothing to promote for %s." (Path.Source.to_string_maybe_quoted fn) + |> Pp.tag User_message.Style.Warning + ] ;; module Apply = struct @@ -81,7 +51,10 @@ module Apply = struct Scheduler.go_with_rpc_server ~common ~config (fun () -> let open Fiber.O in let+ () = Fiber.return () in - Diff_promotion.promote_files_registered_in_last_run files_to_promote) + let missing = + Diff_promotion.promote_files_registered_in_last_run files_to_promote + in + List.iter ~f:on_missing missing) | Error lock_held_by -> Scheduler.go_without_rpc_server ~common ~config (fun () -> let open Fiber.O in @@ -110,7 +83,11 @@ module Diff = struct let common, config = Common.init builder in let files_to_promote = files_to_promote ~common files in Scheduler.go_with_rpc_server ~common ~config (fun () -> - Diff_promotion.display files_to_promote) + let open Fiber.O in + let db = Diff_promotion.load_db () in + let* missing = Diff_promotion.missing ~db files_to_promote in + List.iter ~f:on_missing missing; + Diff_promotion.display_diffs ~db files_to_promote) ;; let command = Cmd.v info term @@ -128,7 +105,11 @@ module Files = struct let common, config = Common.init builder in let files_to_promote = files_to_promote ~common files in Scheduler.go_with_rpc_server ~common ~config (fun () -> - display_files files_to_promote) + let open Fiber.O in + let db = Diff_promotion.load_db () in + let* missing = Diff_promotion.missing ~db files_to_promote in + List.iter ~f:on_missing missing; + Diff_promotion.display_files ~db files_to_promote) ;; let command = Cmd.v info term @@ -145,7 +126,11 @@ module Show = struct let common, config = Common.init builder in let files_to_promote = files_to_promote ~common files in Scheduler.go_with_rpc_server ~common ~config (fun () -> - show_corrected_contents files_to_promote) + let open Fiber.O in + let db = Diff_promotion.load_db () in + let+ missing = Diff_promotion.missing ~db files_to_promote in + List.iter ~f:on_missing missing; + Diff_promotion.display_corrected_contents ~db files_to_promote) ;; let command = Cmd.v info term diff --git a/bin/rpc/rpc_common.ml b/bin/rpc/rpc_common.ml index 1bbbba44569..1a829914db0 100644 --- a/bin/rpc/rpc_common.ml +++ b/bin/rpc/rpc_common.ml @@ -150,22 +150,49 @@ let fire_notification send_request connection name ~f:(fun client -> notify_exn client notification arg) ;; +let print_err_warn (nb_errors, nb_warns) = + let enumeration = + let report_one what count = + if count = 0 + then [] + else ( + let plural = if count = 1 then "" else "s" in + [ sprintf "%d %s%s" count what plural ]) + in + [ report_one "error" nb_errors; report_one "warning" nb_warns ] + |> List.concat + |> String.enumerate_and + in + if nb_errors >= 1 + then User_error.raise [ Pp.textf "Build failed with %s." enumeration ] + else User_warning.emit [ Pp.textf "Build completed with %s." enumeration ] +;; + let wrap_build_outcome_exn ~print_on_success build_outcome = match build_outcome with | Dune_rpc.Build_outcome_with_diagnostics.Success -> if print_on_success then Console.print [ Pp.text "Success" |> Pp.tag User_message.Style.Success ] | Failure errors -> - let error_msg = - match List.length errors with - | 0 -> - Code_error.raise - "Build via RPC failed, but the RPC server did not send an error message." - [] - | 1 -> Pp.paragraph "Build failed with 1 error." - | n -> Pp.paragraphf "Build failed with %d errors." n + let counts = + List.fold_left + errors + ~init:(0, 0) + ~f: + (fun + (nb_errors, nb_warnings) { Dune_rpc.Compound_user_error.main; severity; _ } -> + match severity with + | Error -> + Console.print_user_message main; + nb_errors + 1, nb_warnings + | Warning -> + User_warning.emit_message main; + nb_errors, nb_warnings + 1) in - List.iter errors ~f:(fun { Dune_rpc.Compound_user_error.main; _ } -> - Console.print_user_message main); - User_error.raise [ error_msg |> Pp.tag User_message.Style.Error ] + if counts == (0, 0) + then + Code_error.raise + "Build via RPC failed, but the RPC server did not send an error message." + []; + print_err_warn counts ;; diff --git a/otherlibs/dune-rpc/private/exported_types.ml b/otherlibs/dune-rpc/private/exported_types.ml index b295e9efa48..c6c799e5194 100644 --- a/otherlibs/dune-rpc/private/exported_types.ml +++ b/otherlibs/dune-rpc/private/exported_types.ml @@ -206,7 +206,7 @@ module Ansi_color = struct end module Pp = struct - include Pp + include Stdune.Pp let sexp (conv_tag : 'a Conv.value) : 'a Pp.t Conv.value = let open Conv in @@ -545,6 +545,11 @@ module Diagnostic = struct enum [ "error", Error; "warning", Warning ] ;; + let severity_to_dyn = function + | Error -> Dyn.string "error" + | Warning -> Dyn.string "warning" + ;; + let sexp = let open Conv in let from { targets; message; loc; severity; promotion; directory; id; related } = @@ -708,9 +713,10 @@ module Compound_user_error = struct type t = { main : User_message.t ; related : User_message.t list + ; severity : Diagnostic.severity } - let create ~main ~related = + let create ~main ~related ~severity = let () = List.iter related ~f:(fun (related : User_message.t) -> match related.loc with @@ -720,23 +726,25 @@ module Compound_user_error = struct "related messages must have locations" [ "related", String (Stdune.User_message.to_string related) ]) in - { main; related } + { main; related; severity } ;; let sexp = let open Conv in - let from { main; related } = main, related in - let to_ (main, related) = create ~main ~related in + let from { main; related; severity } = main, related, severity in + let to_ (main, related, severity) = create ~main ~related ~severity in let main = field "main" (required User_message.sexp_without_annots) in let related = field "related" (required (list User_message.sexp_without_annots)) in - iso (record (both main related)) to_ from + let severity = field "severity" (required Diagnostic.sexp_severity) in + iso (record (three main related severity)) to_ from ;; - let to_dyn { main; related } = + let to_dyn { main; related; severity } = let open Dyn in record [ "main", string (Stdune.User_message.to_string main) ; "related", (list string) (List.map related ~f:Stdune.User_message.to_string) + ; "severity", Diagnostic.severity_to_dyn severity ] ;; @@ -744,7 +752,8 @@ module Compound_user_error = struct Stdune.User_message.Annots.Key.create ~name:"compound-user-error" (Dyn.list to_dyn) ;; - let make ~main ~related = create ~main ~related + let make ~main ~related = create ~main ~related ~severity:Error + let make_with_severity ~main ~related ~severity = create ~main ~related ~severity let make_loc ~dir { Ocamlc_loc.path; chars; lines } : Stdune.Loc.t = let pos_fname = @@ -777,7 +786,15 @@ module Compound_user_error = struct in let main = make_message (report.loc, report.message) in let related = List.map report.related ~f:make_message in - make ~main ~related) + let severity : Diagnostic.severity = + match report.severity with + | Error _ -> Error + | Warning _ -> Warning + | Alert _ -> + (* CR-someday ElectreAAS: parse alerts as alerts directly *) + Warning + in + make_with_severity ~main ~related ~severity) ;; end @@ -814,25 +831,17 @@ end module Files_to_promote = struct type t = | All - | These of Stdune.Path.Source.t list * (Stdune.Path.Source.t -> unit) - - let on_missing fn = - Stdune.User_warning.emit - [ Pp.paragraphf - "Nothing to promote for %s." - (Stdune.Path.Source.to_string_maybe_quoted fn) - ] - ;; + | These of Stdune.Path.Source.t list let sexp = let open Conv in let to_ = function | [] -> All - | paths -> These (List.map ~f:Stdune.Path.Source.of_string paths, on_missing) + | paths -> These (List.map ~f:Stdune.Path.Source.of_string paths) in let from = function | All -> [] - | These (paths, _) -> List.map ~f:Stdune.Path.Source.to_string paths + | These paths -> List.map ~f:Stdune.Path.Source.to_string paths in iso (list Path.sexp) to_ from ;; diff --git a/otherlibs/dune-rpc/private/exported_types.mli b/otherlibs/dune-rpc/private/exported_types.mli index 67491a01d09..d2dede21d96 100644 --- a/otherlibs/dune-rpc/private/exported_types.mli +++ b/otherlibs/dune-rpc/private/exported_types.mli @@ -1,5 +1,11 @@ (** Types exposed to end-user consumers of [dune_rpc.mli]. *) +module Pp : sig + include module type of Stdune.Pp + + val sexp : 'a Conv.value -> 'a t Conv.value +end + module Loc : sig type t = Stdune.Lexbuf.Loc.t = { start : Lexing.position @@ -80,6 +86,8 @@ module User_message : sig | Debug | Success | Ansi_styles of Ansi_color.Style.t list + + val sexp : t Conv.value end type t = Stdune.User_message.t @@ -227,12 +235,22 @@ module Compound_user_error : sig type t = private { main : User_message.t ; related : User_message.t list + ; severity : Diagnostic.severity } val sexp : t Conv.value val to_dyn : t -> Dyn.t val annot : t list Stdune.User_message.Annots.Key.t + + (** Make a [t] with severity as [Error]. *) val make : main:User_message.t -> related:User_message.t list -> t + + val make_with_severity + : main:User_message.t + -> related:User_message.t list + -> severity:Diagnostic.severity + -> t + val parse_output : dir:Stdune.Path.t -> string -> t list end @@ -246,12 +264,11 @@ module Build_outcome_with_diagnostics : sig val sexp : t Conv.value end -(** Describe what files should be promoted. The second argument of [These] is a - function that is called on files that cannot be promoted. *) +(** Describe what files should be promoted. *) module Files_to_promote : sig type t = | All - | These of Stdune.Path.Source.t list * (Stdune.Path.Source.t -> unit) + | These of Stdune.Path.Source.t list val sexp : t Conv.value end diff --git a/src/dune_rpc_impl/diagnostics.ml b/src/dune_rpc_impl/diagnostics.ml index ac279031321..8dafe85bb56 100644 --- a/src/dune_rpc_impl/diagnostics.ml +++ b/src/dune_rpc_impl/diagnostics.ml @@ -24,12 +24,13 @@ let diagnostic_of_error : Build_system_error.t -> Dune_rpc_private.Diagnostic.t let dir = Option.value ~default:Path.root dir in absolutize_paths ~dir loc in - let message, related = + let message, related, severity = match Build_system_error.description m with | `Exn e -> (* CR-someday jeremiedimino: Use [Report_error.get_user_message] here. *) - User_message.make [ Pp.text (Printexc.to_string e.exn) ], [] - | `Diagnostic { Compound_user_error.main = message; related } -> message, related + User_message.make [ Pp.text (Printexc.to_string e.exn) ], [], Some Diagnostic.Error + | `Diagnostic { Compound_user_error.main = message; related; severity } -> + message, related, Some severity in let loc = Option.map message.loc ~f:make_loc in let id = @@ -65,7 +66,7 @@ let diagnostic_of_error : Build_system_error.t -> Dune_rpc_private.Diagnostic.t in List.map paragraphs ~f:Pp.box |> Pp.concat ~sep:Pp.cut |> Pp.vbox in - { Dune_rpc_private.Diagnostic.severity = Some Dune_rpc_private.Diagnostic.Error + { Dune_rpc_private.Diagnostic.severity ; id ; targets = [] ; message diff --git a/src/dune_rpc_impl/server.ml b/src/dune_rpc_impl/server.ml index 0d3fc831a62..7779e0a4e9a 100644 --- a/src/dune_rpc_impl/server.ml +++ b/src/dune_rpc_impl/server.ml @@ -369,8 +369,16 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = (* A 'successful' formatting means there is nothing to promote. *) | Success -> () | Failure -> - Promote.Diff_promotion.promote_files_registered_in_last_run - Dune_rpc.Files_to_promote.All + let missing = + Promote.Diff_promotion.promote_files_registered_in_last_run + Dune_rpc.Files_to_promote.All + in + if List.is_non_empty missing + then + Code_error.raise + "promote_files_registered_in_last_run All should always return an empty list" + []; + () in Handler.implement_request rpc Procedures.Public.format f in @@ -423,16 +431,31 @@ let handler (t : _ t Fdecl.t) handle : 'build_arg Dune_rpc_server.Handler.t = in let () = let f _ files = - Promote.Diff_promotion.promote_files_registered_in_last_run files; - Fiber.return Dune_rpc.Build_outcome_with_diagnostics.Success + match Promote.Diff_promotion.promote_files_registered_in_last_run files with + | [] -> Fiber.return Dune_rpc.Build_outcome_with_diagnostics.Success + | missing -> + let warnings = + List.map missing ~f:(fun fn -> + Dune_rpc.Compound_user_error.make_with_severity + ~main: + (User_message.make + [ Pp.paragraphf + "Nothing to promote for %s." + (Path.Source.to_string_maybe_quoted fn) + ]) + ~related:[] + ~severity:Dune_rpc.Diagnostic.Warning) + in + Fiber.return (Dune_rpc.Build_outcome_with_diagnostics.Failure warnings) in Handler.implement_request rpc Procedures.Public.promote_many f in let () = let f _ path = let files = For_handlers.source_path_of_string path in - Promote.Diff_promotion.promote_files_registered_in_last_run - (These ([ files ], ignore)); + let _ignored : Path.Source.t list = + Promote.Diff_promotion.promote_files_registered_in_last_run (These [ files ]) + in Fiber.return () in Handler.implement_request rpc Procedures.Public.promote f diff --git a/src/promote/diff_promotion.ml b/src/promote/diff_promotion.ml index fc3d1115a88..d0a32d78946 100644 --- a/src/promote/diff_promotion.ml +++ b/src/promote/diff_promotion.ml @@ -130,13 +130,11 @@ let group_by_targets db = ~f:(List.sort ~compare:(fun (x, _) (y, _) -> Path.Build.compare x y)) ;; -let do_promote db files_to_promote = - let by_targets = group_by_targets db in - let promote_one dst srcs = - match srcs with - | [] -> assert false - | (src, staging) :: others -> - (* We used to remove promoted files from the digest cache, to force Dune +let promote_one dst srcs = + match srcs with + | [] -> assert false + | (src, staging) :: others -> + (* We used to remove promoted files from the digest cache, to force Dune to redigest them on the next run. We did this because on OSX [mtime] is not precise enough and if a file is modified and promoted quickly, it looked like it hadn't changed even though it might have. @@ -149,47 +147,61 @@ let do_promote db files_to_promote = not promote into the build directory anyway), and source digests should be correctly invalidated via [fs_memo]. If that doesn't happen, we should fix [fs_memo] instead of manually resetting the caches here. *) - File.promote { src; staging; dst }; - List.iter others ~f:(fun (path, _staging) -> - Console.print - [ Pp.textf " -> ignored %s." (Path.to_string_maybe_quoted (Path.build path)) - ; Pp.space - ]) + File.promote { src; staging; dst }; + List.iter others ~f:(fun (path, _staging) -> + Console.print + [ Pp.textf " -> ignored %s." (Path.to_string_maybe_quoted (Path.build path)) + ; Pp.space + ]) +;; + +let do_promote_all db = group_by_targets db |> Path.Source.Map.iteri ~f:promote_one + +let do_promote_these db files = + let by_targets = group_by_targets db in + let by_targets, missing = + let files = Path.Source.Set.of_list files in + Path.Source.Set.fold files ~init:(by_targets, []) ~f:(fun fn (map, missing) -> + match Path.Source.Map.find map fn with + | None -> map, fn :: missing + | Some srcs -> + promote_one fn srcs; + Path.Source.Map.remove map fn, missing) in - match files_to_promote with - | Dune_rpc_private.Files_to_promote.All -> - Path.Source.Map.iteri by_targets ~f:promote_one; - [] - | These (files, on_missing) -> - let by_targets = - let files = Path.Source.Set.of_list files in - Path.Source.Set.fold files ~init:by_targets ~f:(fun fn map -> - match Path.Source.Map.find by_targets fn with - | None -> - on_missing fn; - map - | Some srcs -> - promote_one fn srcs; - Path.Source.Map.remove by_targets fn) - in + let remaining = Path.Source.Map.to_list by_targets |> List.concat_map ~f:(fun (dst, srcs) -> List.map srcs ~f:(fun (src, staging) -> { File.src; staging; dst })) + in + let sorted_missing = List.rev missing in + remaining, sorted_missing +;; + +let do_promote db = function + | Dune_rpc_private.Files_to_promote.All -> + do_promote_all db; + [], [] + | These files -> do_promote_these db files ;; let finalize () = let db = match !Dune_engine.Clflags.promote with - | Some Automatically -> do_promote !File.db All + | Some Automatically -> + do_promote_all !File.db; + [] | Some Never | None -> !File.db in dump_db db ;; +(* Returns the list of files that were in [files_to_promote] + but not present in the promotion database. *) let promote_files_registered_in_last_run files_to_promote = let db = load_db () in - let db = do_promote db files_to_promote in - dump_db db + let remaining, missing = do_promote db files_to_promote in + dump_db remaining; + missing ;; let diff_for_file (file : File.t) = @@ -199,19 +211,23 @@ let diff_for_file (file : File.t) = Print_diff.get msg original correction ;; -let filter_db files_to_promote db = +(** [partition_db db files_to_promote] splits [files_to_promote] into two lists + - The files present in [db] as actual [File.t]s. + - The files absent from [db] as [Path]s. *) +let partition_db db files_to_promote = match files_to_promote with - | Dune_rpc_private.Files_to_promote.All -> db - | These (files, on_missing) -> - List.filter_map files ~f:(fun file -> - let r = List.find db ~f:(fun (f : File.t) -> Path.Source.equal f.dst file) in - if Option.is_none r then on_missing file; - r) + | Dune_rpc_private.Files_to_promote.All -> db, [] + | These paths -> + List.partition_map paths ~f:(fun path -> + let res = List.find db ~f:(fun (f : File.t) -> Path.Source.equal f.dst path) in + match res with + | Some file -> Left file + | None -> Right path) ;; -let display files_to_promote = +let sort_for_display db files_to_promote = let open Fiber.O in - let files = load_db () |> filter_db files_to_promote in + let files, missing = partition_db db files_to_promote in let+ diff_opts = Fiber.parallel_map files ~f:(fun file -> let+ diff_opt = diff_for_file file in @@ -219,8 +235,46 @@ let display files_to_promote = | Ok diff -> Some (file, diff) | Error _ -> None) in - diff_opts - |> List.filter_opt - |> List.sort ~compare:(fun (file, _) (file', _) -> File.compare file file') - |> List.iter ~f:(fun (_file, diff) -> Print_diff.Diff.print diff) + let sorted_diffs = + diff_opts + |> List.filter_opt + |> List.sort ~compare:(fun (file, _) (file', _) -> File.compare file file') + in + let sorted_missing = List.sort missing ~compare:Path.Source.compare in + sorted_diffs, sorted_missing +;; + +let missing ~db files_to_promote = + let open Fiber.O in + let+ _diffs, missing = sort_for_display db files_to_promote in + missing +;; + +let display_diffs ~db files_to_promote = + let open Fiber.O in + let+ diffs, _missing = sort_for_display db files_to_promote in + List.iter diffs ~f:(fun (_file, diff) -> Print_diff.Diff.print diff) +;; + +let display_files ~db files_to_promote = + let open Fiber.O in + let+ diffs, _missing = sort_for_display db files_to_promote in + List.iter diffs ~f:(fun (file, _diff) -> + Console.printf "%s" (File.source file |> Path.Source.to_string)) +;; + +let display_corrected_contents ~db files_to_promote = + let files, _missing = partition_db db files_to_promote in + List.iter files ~f:(fun file -> + let correction_file = File.correction_file file in + if Path.exists correction_file + then ( + let contents = Io.read_file correction_file in + Console.printf "%s" contents) + else + User_warning.emit + [ Pp.textf + "Corrected file does not exist for %s." + (File.source file |> Path.Source.to_string_maybe_quoted) + ]) ;; diff --git a/src/promote/diff_promotion.mli b/src/promote/diff_promotion.mli index 4c5cc75a460..7be70fa2c07 100644 --- a/src/promote/diff_promotion.mli +++ b/src/promote/diff_promotion.mli @@ -28,7 +28,28 @@ end val finalize : unit -> unit val load_db : unit -> File.t list -val filter_db : Dune_rpc_private.Files_to_promote.t -> File.t list -> File.t list -val diff_for_file : File.t -> (Print_diff.Diff.t, User_message.t) result Fiber.t -val promote_files_registered_in_last_run : Dune_rpc_private.Files_to_promote.t -> unit -val display : Dune_rpc_private.Files_to_promote.t -> unit Fiber.t + +val promote_files_registered_in_last_run + : Dune_rpc_private.Files_to_promote.t + -> Path.Source.t list + +(** [missing ~db files] returns the list of files in [files] but not in [db]. *) +val missing + : db:File.t list + -> Dune_rpc_private.Files_to_promote.t + -> Path.Source.t list Fiber.t + +(** [display_diffs ~db files] will only print the diffs of files that are both + in [files] and in [db]. *) +val display_diffs : db:File.t list -> Dune_rpc_private.Files_to_promote.t -> unit Fiber.t + +(** [display_file_names ~db files] will only print the filenames of files that are + both in [files] and in [db]. *) +val display_files : db:File.t list -> Dune_rpc_private.Files_to_promote.t -> unit Fiber.t + +(** [display_corrected_contents ~db files] will print the changes in plain text + of files that are both in [files] and in [db]. *) +val display_corrected_contents + : db:File.t list + -> Dune_rpc_private.Files_to_promote.t + -> unit diff --git a/test/blackbox-tests/test-cases/promote/promotion-show.t b/test/blackbox-tests/test-cases/promote/promotion-show.t index b5442b124e7..b2b726634a0 100644 --- a/test/blackbox-tests/test-cases/promote/promotion-show.t +++ b/test/blackbox-tests/test-cases/promote/promotion-show.t @@ -253,5 +253,5 @@ This 'diff?' rule also doesn't create a promotion entry. When multiple files have no promotions available, each gets a warning. $ dune promotion show multi.expected empty.expected - Warning: Nothing to promote for multi.expected. Warning: Nothing to promote for empty.expected. + Warning: Nothing to promote for multi.expected. diff --git a/test/blackbox-tests/test-cases/watching/promotion-db.t b/test/blackbox-tests/test-cases/watching/promotion-db.t deleted file mode 100644 index 11b6ca0079d..00000000000 --- a/test/blackbox-tests/test-cases/watching/promotion-db.t +++ /dev/null @@ -1,70 +0,0 @@ -Demonstrate bug where the RPC promotion doesn't print a warning where the normal promotion does. - - $ . ./helpers.sh - - $ echo '(lang dune 3.20)' > dune-project - -Something to promote for a - $ echo " $ echo hello" > a.t - -Nothing to promote for b - $ cat > b.t << EOF - > $ echo hello - > hello - > EOF - -Something to promote for c, but we don't care for it right now. - $ echo " $ echo hello" > c.t - -Promoting a at this point does nothing, and we print a warning. - $ dune promote a.t - Warning: Nothing to promote for a.t. - - $ start_dune - $ dune rpc ping --wait - Server appears to be responding normally - -This should be a warning for a and b. - $ dune promote a.t b.t - Success - -Now a is in the promotion database, - $ build "(alias a)" - Failure - -and c as well. - $ build "(alias c)" - Failure - -This should be a success for a (and print nothing), and a warning for b. - $ dune promote a.t b.t - Success - -This is incorrect! - $ cat a.t - $ echo hello - - $ cat b.t - $ echo hello - hello - -C should still be in the database at this point, and promotion should work. - $ dune promote c.t - Success - - $ cat c.t - $ echo hello - hello - - $ stop_dune - Warning: Nothing to promote for a.t. - Warning: Nothing to promote for b.t. - File "a.t", line 1, characters 0-0: - Error: Files _build/default/a.t and _build/default/a.t.corrected differ. - Had 1 error, waiting for filesystem changes... - File "c.t", line 1, characters 0-0: - Error: Files _build/default/c.t and _build/default/c.t.corrected differ. - Had 1 error, waiting for filesystem changes... - Warning: Nothing to promote for a.t. - Warning: Nothing to promote for b.t. - Promoting _build/default/c.t.corrected to c.t. diff --git a/test/blackbox-tests/test-cases/watching/warnings.t b/test/blackbox-tests/test-cases/watching/warnings.t new file mode 100644 index 00000000000..c5b3ab71021 --- /dev/null +++ b/test/blackbox-tests/test-cases/watching/warnings.t @@ -0,0 +1,47 @@ +Preventing regression about the RPC promotion which didn't print a warning +where the normal promotion did. They should now be the same. + + $ . ./helpers.sh + + $ echo '(lang dune 3.20)' > dune-project + +Something to promote for A + $ echo " $ echo hello" > a.t + +Nothing to promote for B + $ cat > b.t << EOF + > $ echo hello + > hello + > EOF + +Promoting A at this point does nothing, and we print a warning. + $ dune promote a.t + Warning: Nothing to promote for a.t. + + $ start_dune + $ dune rpc ping --wait + Server appears to be responding normally + +This should be a warning for both A and B. + $ dune promote a.t b.t + Warning: Nothing to promote for a.t. + Warning: Nothing to promote for b.t. + Warning: Build completed with 2 warnings. + +Now A is in the promotion database. + $ dune build @a + File "a.t", line 1, characters 0-0: + Error: Files _build/default/a.t and _build/default/a.t.corrected differ. + Error: Build failed with 1 error. + [1] + +This should be a success for A (and print nothing), and a warning for B. + $ dune promote a.t b.t + Warning: Nothing to promote for b.t. + Warning: Build completed with 1 warning. + + $ stop_dune + File "a.t", line 1, characters 0-0: + Error: Files _build/default/a.t and _build/default/a.t.corrected differ. + Had 1 error, waiting for filesystem changes... + Promoting _build/default/a.t.corrected to a.t. diff --git a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml index d5391d88360..344dd7d5ec7 100644 --- a/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml +++ b/test/expect-tests/dune_rpc_e2e/dune_rpc_diagnostics.ml @@ -388,12 +388,40 @@ let%expect_test "optional promotion" = ] |}] ;; -let%expect_test "warning detection" = +(* Non-fatal warnings aren't transferred to the RPC client. *) +let%expect_test "warning non-detection" = diagnostic_with_build - [ "dune", "(executable (flags -w +26) (name foo))" + [ "dune", "(executable (flags (-w +26)) (name foo))" ; "foo.ml", "let () = let x = 10 in ()" ] "./foo.exe"; + [%expect + {| + Building ./foo.exe + Build ./foo.exe succeeded + |}] +;; + +(* Alerts aren't transferred to the RPC client. *) +let%expect_test "alert non-detection" = + diagnostic_with_build + [ "dune", "(executable (name foo))" + ; ( "foo.ml" + , {| +module A : sig + + val f : unit + [@@alert foo "foobar"] + +end = struct + let f = () +end + +let () = A.f +|} + ) + ] + "./foo.exe"; [%expect {| Building ./foo.exe @@ -703,118 +731,119 @@ let g = A.f let+ () = print_diagnostics poll in [%expect {| - [ "Add" - ; [ [ "directory"; "$CWD" ] - ; [ "id"; "0" ] - ; [ "loc" - ; [ [ "start" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "8" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "11" ] - ] + [ "Add" + ; [ [ "directory"; "$CWD" ] + ; [ "id"; "0" ] + ; [ "loc" + ; [ [ "start" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "8" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "11" ] ] - ; [ "stop" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "11" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "11" ] - ] + ] + ; [ "stop" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "11" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "11" ] ] ] ] - ; [ "message"; [ "Verbatim"; "foobar\n\ - " ] ] - ; [ "promotion"; [] ] - ; [ "related"; [] ] - ; [ "severity"; "error" ] - ; [ "targets"; [] ] ] + ; [ "message"; [ "Verbatim"; "foobar\n\ + " ] ] + ; [ "promotion"; [] ] + ; [ "related"; [] ] + ; [ "severity"; "warning" ] + ; [ "targets"; [] ] ] - [ "Add" - ; [ [ "directory"; "$CWD" ] - ; [ "id"; "1" ] - ; [ "loc" - ; [ [ "start" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "8" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "12" ] - ] + ] + [ "Add" + ; [ [ "directory"; "$CWD" ] + ; [ "id"; "1" ] + ; [ "loc" + ; [ [ "start" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "8" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "12" ] ] - ; [ "stop" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "11" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "12" ] - ] + ] + ; [ "stop" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "11" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "12" ] ] ] ] - ; [ "message"; [ "Verbatim"; "foobar\n\ - " ] ] - ; [ "promotion"; [] ] - ; [ "related"; [] ] - ; [ "severity"; "error" ] - ; [ "targets"; [] ] ] + ; [ "message"; [ "Verbatim"; "foobar\n\ + " ] ] + ; [ "promotion"; [] ] + ; [ "related"; [] ] + ; [ "severity"; "warning" ] + ; [ "targets"; [] ] ] - [ "Add" - ; [ [ "directory"; "$CWD" ] - ; [ "id"; "2" ] - ; [ "loc" - ; [ [ "start" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "4" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "11" ] - ] + ] + [ "Add" + ; [ [ "directory"; "$CWD" ] + ; [ "id"; "2" ] + ; [ "loc" + ; [ [ "start" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "4" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "11" ] ] - ; [ "stop" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "5" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "11" ] - ] + ] + ; [ "stop" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "5" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "11" ] ] ] ] - ; [ "message"; [ "Verbatim"; "unused value f.\n\ - " ] ] - ; [ "promotion"; [] ] - ; [ "related"; [] ] - ; [ "severity"; "error" ] - ; [ "targets"; [] ] ] + ; [ "message"; [ "Verbatim"; "unused value f.\n\ + " ] ] + ; [ "promotion"; [] ] + ; [ "related"; [] ] + ; [ "severity"; "error" ] + ; [ "targets"; [] ] ] - [ "Add" - ; [ [ "directory"; "$CWD" ] - ; [ "id"; "3" ] - ; [ "loc" - ; [ [ "start" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "4" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "12" ] - ] + ] + [ "Add" + ; [ [ "directory"; "$CWD" ] + ; [ "id"; "3" ] + ; [ "loc" + ; [ [ "start" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "4" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "12" ] ] - ; [ "stop" - ; [ [ "pos_bol"; "0" ] - ; [ "pos_cnum"; "5" ] - ; [ "pos_fname"; "$CWD/foo.ml" ] - ; [ "pos_lnum"; "12" ] - ] + ] + ; [ "stop" + ; [ [ "pos_bol"; "0" ] + ; [ "pos_cnum"; "5" ] + ; [ "pos_fname"; "$CWD/foo.ml" ] + ; [ "pos_lnum"; "12" ] ] ] ] - ; [ "message"; [ "Verbatim"; "unused value g.\n\ - " ] ] - ; [ "promotion"; [] ] - ; [ "related"; [] ] - ; [ "severity"; "error" ] - ; [ "targets"; [] ] ] - ] |}]) + ; [ "message"; [ "Verbatim"; "unused value g.\n\ + " ] ] + ; [ "promotion"; [] ] + ; [ "related"; [] ] + ; [ "severity"; "error" ] + ; [ "targets"; [] ] + ] + ] + |}]) ;; let%expect_test "cyclic dependency error simple" =