Fix rpc not transferring promotion warnings to the client

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

bin/rpc/rpc_common.ml

@@ -150,22 +150,57 @@ let fire_notification
   send_request connection name ~f:(fun client -> notify_exn client notification arg)
 ;;
 
+let print_err_warn_alert (nb_errors, nb_warns, nb_alerts) =
+  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
+    ; report_one "alert" nb_alerts
+    ]
+    |> 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, 0)
+        ~f:
+          (fun
+            (nb_errors, nb_warnings, nb_alerts)
+            { Dune_rpc.Compound_user_error.main; severity; _ }
+          ->
+          match severity with
+          | Error ->
+            Console.print_user_message main;
+            nb_errors + 1, nb_warnings, nb_alerts
+          | Warning ->
+            User_warning.emit_message main;
+            nb_errors, nb_warnings + 1, nb_alerts
+          | Alert ->
+            Console.print_user_message main;
+            nb_errors, nb_warnings, nb_alerts + 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, 0)
+    then
+      Code_error.raise
+        "Build via RPC failed, but the RPC server did not send an error message."
+        [];
+    print_err_warn_alert counts
 ;;

otherlibs/dune-rpc/private/diagnostics_v1.ml

@@ -1,6 +1,10 @@
 open Import
 open Exported_types
 
+type severity =
+  | Error
+  | Warning
+
 module Related = struct
   type t =
     { message : unit Pp.t
@@ -32,15 +36,15 @@ type t =
   ; id : Diagnostic.Id.t
   ; message : unit Pp.t
   ; loc : Loc.t option
-  ; severity : Diagnostic.severity option
+  ; severity : severity option
   ; promotion : Diagnostic.Promotion.t list
   ; directory : string option
   ; related : Related.t list
   }
 
 let sexp_severity =
   let open Conv in
-  enum [ "error", Diagnostic.Error; "warning", Warning ]
+  enum [ "error", Error; "warning", Warning ]
 ;;
 
 let sexp =
@@ -69,7 +73,10 @@ let to_diagnostic t : Diagnostic.t =
   { targets = t.targets
   ; message = t.message |> Pp.map_tags ~f:(fun _ -> User_message.Style.Details)
   ; loc = t.loc
-  ; severity = t.severity
+  ; severity =
+      Option.map t.severity ~f:(function
+        | Error -> Diagnostic.Error
+        | Warning -> Warning)
   ; promotion = t.promotion
   ; directory = t.directory
   ; id = t.id
@@ -81,7 +88,11 @@ let of_diagnostic (t : Diagnostic.t) =
   { targets = t.targets
   ; message = t.message |> Pp.map_tags ~f:(fun _ -> ())
   ; loc = t.loc
-  ; severity = t.severity
+  ; severity =
+      Option.map t.severity ~f:(function
+        | Diagnostic.Error -> Error
+        | Warning -> Warning
+        | Alert -> Warning)
   ; promotion = t.promotion
   ; directory = t.directory
   ; id = t.id

otherlibs/dune-rpc/private/diagnostics_v1.mli

@@ -1,5 +1,9 @@
 (** V1 of the diagnostics module. *)
 
+type severity =
+  | Error
+  | Warning
+
 module Related : sig
   type t
 
@@ -9,14 +13,14 @@ end
 
 type t
 
-val sexp : (t, Conv.values) Conv.t
+val sexp : t Conv.value
 val to_diagnostic : t -> Exported_types.Diagnostic.t
 val of_diagnostic : Exported_types.Diagnostic.t -> t
 
 module Event : sig
   type t
 
-  val sexp : (t, Conv.values) Conv.t
+  val sexp : t Conv.value
   val to_event : t -> Exported_types.Diagnostic.Event.t
   val of_event : Exported_types.Diagnostic.Event.t -> t
 end

otherlibs/dune-rpc/private/diagnostics_v2.ml

@@ -0,0 +1,99 @@
+open Import
+open Exported_types
+
+type t =
+  { targets : Target.t list
+  ; id : Diagnostic.Id.t
+  ; message : User_message.Style.t Pp.t
+  ; loc : Loc.t option
+  ; severity : Diagnostics_v1.severity option
+  ; promotion : Diagnostic.Promotion.t list
+  ; directory : string option
+  ; related : Diagnostic.Related.t list
+  }
+
+let sexp_severity =
+  let open Conv in
+  enum [ "error", Diagnostics_v1.Error; "warning", Warning ]
+;;
+
+let sexp =
+  let open Conv in
+  let from { targets; message; loc; severity; promotion; directory; id; related } =
+    targets, message, loc, severity, promotion, directory, id, related
+  in
+  let to_ (targets, message, loc, severity, promotion, directory, id, related) =
+    { targets; message; loc; severity; promotion; directory; id; related }
+  in
+  let loc = field "loc" (optional Loc.sexp) in
+  let message = field "message" (required (Pp.sexp User_message.Style.sexp)) in
+  let targets = field "targets" (required (list Target.sexp)) in
+  let severity = field "severity" (optional sexp_severity) in
+  let directory = field "directory" (optional string) in
+  let promotion = field "promotion" (required (list Diagnostic.Promotion.sexp)) in
+  let id = field "id" (required Diagnostic.Id.sexp) in
+  let related = field "related" (required (list Diagnostic.Related.sexp)) in
+  iso
+    (record (eight targets message loc severity promotion directory id related))
+    to_
+    from
+;;
+
+let to_diagnostic t : Diagnostic.t =
+  { targets = t.targets
+  ; message = t.message
+  ; loc = t.loc
+  ; severity =
+      Option.map t.severity ~f:(function
+        | Error -> Diagnostic.Error
+        | Warning -> Warning)
+  ; promotion = t.promotion
+  ; directory = t.directory
+  ; id = t.id
+  ; related = t.related
+  }
+;;
+
+let of_diagnostic (t : Diagnostic.t) =
+  { targets = t.targets
+  ; message = t.message
+  ; loc = t.loc
+  ; severity =
+      Option.map t.severity ~f:(function
+        | Diagnostic.Error -> Diagnostics_v1.Error
+        | Warning -> Warning
+        | Alert -> Warning)
+  ; promotion = t.promotion
+  ; directory = t.directory
+  ; id = t.id
+  ; related = t.related
+  }
+;;
+
+module Event = struct
+  type nonrec t =
+    | Add of t
+    | Remove of t
+
+  let sexp =
+    let diagnostic = sexp in
+    let open Conv in
+    let add = constr "Add" diagnostic (fun a -> Add a) in
+    let remove = constr "Remove" diagnostic (fun a -> Remove a) in
+    sum
+      [ econstr add; econstr remove ]
+      (function
+        | Add t -> case t add
+        | Remove t -> case t remove)
+  ;;
+
+  let to_event : t -> Diagnostic.Event.t = function
+    | Add t -> Add (to_diagnostic t)
+    | Remove t -> Remove (to_diagnostic t)
+  ;;
+
+  let of_event : Diagnostic.Event.t -> t = function
+    | Add t -> Add (of_diagnostic t)
+    | Remove t -> Remove (of_diagnostic t)
+  ;;
+end

otherlibs/dune-rpc/private/diagnostics_v2.mli

@@ -0,0 +1,15 @@
+(** V2 of the diagnostics module. *)
+
+type t
+
+val sexp : (t, Conv.values) Conv.t
+val to_diagnostic : t -> Exported_types.Diagnostic.t
+val of_diagnostic : Exported_types.Diagnostic.t -> t
+
+module Event : sig
+  type t
+
+  val sexp : t Conv.value
+  val to_event : t -> Exported_types.Diagnostic.Event.t
+  val of_event : Exported_types.Diagnostic.Event.t -> t
+end