Fix promotion not having warnings

Signed-off-by: Ambre Austen Suhamy <[email protected]>

Author: ElectreAAS

bin/promotion.ml

@@ -8,26 +8,12 @@ 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)
+    These files
 ;;
 
-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))
+let on_missing fn =
+  User_warning.emit
+    [ Pp.paragraphf "Nothing to promote for %s." (Path.Source.to_string_maybe_quoted fn) ]
 ;;
 
 module Apply = struct
@@ -60,7 +46,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 missing ~f:on_missing)
     | Error lock_held_by ->
       Scheduler.go_without_rpc_server ~common ~config (fun () ->
         let open Fiber.O in
@@ -86,7 +75,7 @@ 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)
+      Diff_promotion.display_diffs ~on_missing files_to_promote)
   ;;
 
   let command = Cmd.v info term
@@ -101,7 +90,7 @@ 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)
+      Diff_promotion.display_files ~on_missing files_to_promote)
   ;;
 
   let command = Cmd.v info term

bin/rpc/rpc_build.ml

@@ -13,6 +13,7 @@ let term =
   in
   match response with
   | Success -> print_endline "Success"
+  | Warn _ -> print_endline "Warn"
   | Failure _ -> print_endline "Failure"
 ;;
 

bin/rpc/rpc_common.ml

@@ -100,12 +100,13 @@ let prepare_targets targets =
 
 let warn_ignore_arguments lock_held_by =
   User_warning.emit
-    [ Pp.paragraphf
-        "Your build request is being forwarded to a running Dune instance%s. Note that \
-         certain command line arguments may be ignored."
-        (match lock_held_by with
-         | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
-         | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
+    [ Pp.tag User_message.Style.Warning
+      @@ Pp.paragraphf
+           "Your build request is being forwarded to a running Dune instance%s. Note \
+            that certain command line arguments may be ignored."
+           (match lock_held_by with
+            | Dune_util.Global_lock.Lock_held_by.Unknown -> ""
+            | Pid_from_lockfile pid -> sprintf " (pid: %d)" pid)
     ]
 ;;
 
@@ -155,6 +156,20 @@ let wrap_build_outcome_exn ~print_on_success build_outcome =
   | Dune_rpc.Build_outcome_with_diagnostics.Success ->
     if print_on_success
     then Console.print [ Pp.text "Success" |> Pp.tag User_message.Style.Success ]
+  | Warn warnings ->
+    let warn_msg =
+      match List.length warnings with
+      | 0 ->
+        Code_error.raise
+          "Build via RPC returned a warning state, but the RPC server did not send any \
+           warnings."
+          []
+      | 1 -> Pp.paragraph "Build completed with 1 warning."
+      | n -> Pp.paragraphf "Build completed with %d warnings." n
+    in
+    List.iter warnings ~f:(fun { Dune_rpc.Compound_user_error.main; _ } ->
+      Console.print_user_message main);
+    User_warning.emit [ Pp.tag User_message.Style.Warning warn_msg ]
   | Failure errors ->
     let error_msg =
       match List.length errors with
@@ -167,5 +182,5 @@ let wrap_build_outcome_exn ~print_on_success build_outcome =
     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 ]
+    User_error.raise [ Pp.tag User_message.Style.Error error_msg ]
 ;;

otherlibs/dune-rpc/private/exported_types.ml

@@ -784,27 +784,34 @@ end
 module Build_outcome_with_diagnostics = struct
   type t =
     | Success
+    | Warn of Compound_user_error.t list
     | Failure of Compound_user_error.t list
 
   let sexp_v1 =
     let open Conv in
     let success = constr "Success" unit (fun () -> Success) in
+    let warn = constr "Warn" unit (fun () -> Warn []) in
     let failure = constr "Failure" unit (fun () -> Failure []) in
-    let variants = [ econstr success; econstr failure ] in
+    let variants = [ econstr success; econstr warn; econstr failure ] in
     sum variants (function
       | Success -> case () success
+      | Warn _ -> case () warn
       | Failure _ -> case () failure)
   ;;
 
   let sexp_v2 =
     let open Conv in
     let success = constr "Success" unit (fun () -> Success) in
+    let warn =
+      constr "Warn" (list Compound_user_error.sexp) (fun warnings -> Warn warnings)
+    in
     let failure =
       constr "Failure" (list Compound_user_error.sexp) (fun errors -> Failure errors)
     in
-    let variants = [ econstr success; econstr failure ] in
+    let variants = [ econstr success; econstr warn; econstr failure ] in
     sum variants (function
       | Success -> case () success
+      | Warn warnings -> case warnings warn
       | Failure errors -> case errors failure)
   ;;
 
@@ -814,25 +821,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
   ;;

otherlibs/dune-rpc/private/exported_types.mli

@@ -239,19 +239,19 @@ end
 module Build_outcome_with_diagnostics : sig
   type t =
     | Success
+    | Warn of Compound_user_error.t list
     | Failure of Compound_user_error.t list
 
   val sexp_v1 : t Conv.value
   val sexp_v2 : t Conv.value
   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

src/dune_rpc_impl/server.ml

@@ -369,8 +369,11 @@ 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 _is_necessarily_empty =
+          Promote.Diff_promotion.promote_files_registered_in_last_run
+            Dune_rpc.Files_to_promote.All
+        in
+        ()
     in
     Handler.implement_request rpc Procedures.Public.format f
   in
@@ -423,16 +426,30 @@ 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
+              ~main:
+                (User_message.make
+                   [ Pp.paragraphf
+                       "Nothing to promote for %s."
+                       (Path.Source.to_string_maybe_quoted fn)
+                   ])
+              ~related:[])
+        in
+        Fiber.return (Dune_rpc.Build_outcome_with_diagnostics.Warn 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 =
+        Promote.Diff_promotion.promote_files_registered_in_last_run (These [ files ])
+      in
       Fiber.return ()
     in
     Handler.implement_request rpc Procedures.Public.promote f

src/promote/diff_promotion.ml

@@ -159,37 +159,41 @@ let do_promote db files_to_promote =
   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 =
+    [], []
+  | These files ->
+    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 ->
-        match Path.Source.Map.find by_targets fn with
-        | None ->
-          on_missing fn;
-          map
+      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 by_targets fn)
+          Path.Source.Map.remove map fn, missing)
     in
-    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 }))
+    ( 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 }))
+    , missing )
 ;;
 
 let finalize () =
   let db =
     match !Dune_engine.Clflags.promote with
-    | Some Automatically -> do_promote !File.db All
+    | Some Automatically ->
+      let _is_necessarily_empty = do_promote !File.db All in
+      []
     | 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,28 +203,50 @@ let diff_for_file (file : File.t) =
   Print_diff.get msg original correction
 ;;
 
-let filter_db files_to_promote db =
+(** [partition_db files_to_promote db] 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 files_to_promote db =
   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 files_to_promote =
   let open Fiber.O in
-  let files = load_db () |> filter_db files_to_promote in
+  let files, missing = load_db () |> partition_db files_to_promote in
   let+ diff_opts =
     Fiber.parallel_map files ~f:(fun file ->
       let+ diff_opt = diff_for_file file in
       match diff_opt with
       | 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 display_diffs ~on_missing files_to_promote =
+  let open Fiber.O in
+  let+ diffs, missing = sort_for_display files_to_promote in
+  List.iter missing ~f:on_missing;
+  List.iter diffs ~f:(fun (_file, diff) -> Print_diff.Diff.print diff)
+;;
+
+let display_files ~on_missing files_to_promote =
+  let open Fiber.O in
+  let+ diffs, missing = sort_for_display files_to_promote in
+  List.iter missing ~f:on_missing;
+  List.iter diffs ~f:(fun (file, _diff) ->
+    Console.printf "%s" (File.source file |> Path.Source.to_string))
 ;;

src/promote/diff_promotion.mli

@@ -27,7 +27,17 @@ 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
+
+val display_diffs
+  :  on_missing:(Path.Source.t -> unit)
+  -> Dune_rpc_private.Files_to_promote.t
+  -> unit Fiber.t
+
+val display_files
+  :  on_missing:(Path.Source.t -> unit)
+  -> Dune_rpc_private.Files_to_promote.t
+  -> unit Fiber.t