Fix promotion not having warnings

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

Author: ElectreAAS

bin/promotion.ml

@@ -8,26 +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)
+    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)
+      |> Pp.tag User_message.Style.Warning
+    ]
 ;;
 
 module Apply = struct
@@ -60,7 +48,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
@@ -86,7 +77,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
@@ -101,7 +96,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

bin/rpc/rpc_common.ml

@@ -106,6 +106,7 @@ let warn_ignore_arguments lock_held_by =
         (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
     ]
 ;;
 
@@ -156,16 +157,44 @@ let wrap_build_outcome_exn ~print_on_success build_outcome =
     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 nb_errors, nb_warnings =
+      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 ]
+    (match nb_errors, nb_warnings with
+     | 0, 0 ->
+       Code_error.raise
+         "Build via RPC failed, but the RPC server did not send an error message."
+         []
+     | 0, n ->
+       User_warning.emit
+         [ Pp.paragraphf
+             "Build completed with %d warning%s."
+             n
+             (if n = 1 then "" else "s")
+           |> Pp.tag User_message.Style.Warning
+         ]
+     | n, m ->
+       User_error.raise
+         [ Pp.paragraphf
+             "Build failed with %d error%s%s."
+             n
+             (if n = 1 then "" else "s")
+             (match m with
+              | 0 -> ""
+              | 1 -> "and 1 warning"
+              | m -> "and " ^ string_of_int m ^ " warnings")
+           |> Pp.tag User_message.Style.Error
+         ])
 ;;

otherlibs/dune-rpc/private/exported_types.ml

@@ -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,31 +726,33 @@ 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
       ]
   ;;
 
   let annot =
     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 ~severity = create ~main ~related ~severity
 
   let make_loc ~dir { Ocamlc_loc.path; chars; lines } : Stdune.Loc.t =
     let pos_fname =
@@ -777,7 +785,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 _ ->
+          (* FIXME: tests expect this, but it's unclear if that should change. *)
+          Error
+      in
+      make ~main ~related ~severity)
   ;;
 end
 
@@ -814,25 +830,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

@@ -227,12 +227,19 @@ 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
-  val make : main:User_message.t -> related:User_message.t list -> t
+
+  val make
+    :  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 +253,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

src/dune_engine/build_system_error.ml

@@ -34,7 +34,11 @@ let of_exn (exn : Exn_with_backtrace.t) =
        [ Diagnostic
            { dir
            ; id = Id.gen ()
-           ; diagnostic = Compound_user_error.make ~main ~related:[]
+           ; diagnostic =
+               Compound_user_error.make
+                 ~main
+                 ~related:[]
+                 ~severity:Dune_rpc_private.Diagnostic.Error
            ; promotion
            }
        ]

src/dune_lang/dune_project.ml

@@ -788,7 +788,11 @@ let make_packages
        let related = [ message loc1; message loc2 ] in
        User_message.Annots.singleton
          Compound_user_error.annot
-         [ Compound_user_error.make ~main:(User_message.make main_message) ~related ]
+         [ Compound_user_error.make
+             ~main:(User_message.make main_message)
+             ~related
+             ~severity:Dune_rpc_private.Diagnostic.Error
+         ]
      in
      User_error.raise
        ~annots

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

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
+              ~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

src/dune_rules/cram/cram_rules.ml

@@ -266,7 +266,7 @@ let rules ~sctx ~dir tests =
                        in
                        User_message.Annots.singleton
                          Compound_user_error.annot
-                         [ Compound_user_error.make ~main ~related ]
+                         [ Compound_user_error.make ~main ~related ~severity:Error ]
                      in
                      User_error.raise
                        ~annots