Parse alerts as alerts directly

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

Author: ElectreAAS

bin/rpc/rpc_common.ml

@@ -151,50 +151,97 @@ let fire_notification
   send_request connection name ~f:(fun client -> notify_exn client notification arg)
 ;;
 
+let print_err_warn_alert =
+  let plural x = if x = 1 then "" else "s" in
+  function
+  | 0, 0, 0 ->
+    Code_error.raise
+      "Build via RPC failed, but the RPC server did not send an error message."
+      []
+  | 0, 0, a ->
+    User_warning.emit
+      [ Pp.paragraphf "Build completed with %d alert%s." a (plural a)
+        |> Pp.tag User_message.Style.Warning
+      ]
+  | 0, w, 0 ->
+    User_warning.emit
+      [ Pp.paragraphf "Build completed with %d warning%s." w (plural w)
+        |> Pp.tag User_message.Style.Warning
+      ]
+  | 0, w, a ->
+    User_warning.emit
+      [ Pp.paragraphf
+          "Build completed with %d warning%s and %d alert%s."
+          w
+          (plural w)
+          a
+          (plural a)
+        |> Pp.tag User_message.Style.Warning
+      ]
+  | e, 0, 0 ->
+    User_error.raise
+      [ Pp.paragraphf "Build failed with %d error%s." e (plural e)
+        |> Pp.tag User_message.Style.Error
+      ]
+  | e, 0, a ->
+    User_error.raise
+      [ Pp.paragraphf
+          "Build failed with %d error%s and %d alert%s."
+          e
+          (plural e)
+          a
+          (plural a)
+        |> Pp.tag User_message.Style.Error
+      ]
+  | e, w, 0 ->
+    User_error.raise
+      [ Pp.paragraphf
+          "Build failed with %d error%s and %d warning%s."
+          e
+          (plural e)
+          w
+          (plural w)
+        |> Pp.tag User_message.Style.Error
+      ]
+  | e, w, a ->
+    User_error.raise
+      [ Pp.paragraphf
+          "Build failed with %d error%s, %d warning%s, and %d alert%s."
+          e
+          (plural e)
+          w
+          (plural w)
+          a
+          (plural a)
+        |> Pp.tag User_message.Style.Error
+      ]
+;;
+
 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 nb_errors, nb_warnings =
+    let nb_errors, nb_warnings, nb_alerts =
       List.fold_left
         errors
-        ~init:(0, 0)
+        ~init:(0, 0, 0)
         ~f:
           (fun
-            (nb_errors, nb_warnings) { Dune_rpc.Compound_user_error.main; severity; _ } ->
+            (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_errors + 1, nb_warnings, nb_alerts
           | Warning ->
             User_warning.emit_message main;
-            nb_errors, nb_warnings + 1)
+            nb_errors, nb_warnings + 1, nb_alerts
+          | Alert ->
+            Console.print_user_message main;
+            nb_errors, nb_warnings, nb_alerts + 1)
     in
-    (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
-         ])
+    print_err_warn_alert (nb_errors, nb_warnings, nb_alerts)
 ;;

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

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
@@ -470,6 +470,7 @@ module Diagnostic = struct
   type severity =
     | Error
     | Warning
+    | Alert
 
   module Promotion = struct
     type t =
@@ -542,12 +543,13 @@ module Diagnostic = struct
 
   let sexp_severity =
     let open Conv in
-    enum [ "error", Error; "warning", Warning ]
+    enum [ "error", Error; "warning", Warning; "alert", Alert ]
   ;;
 
   let severity_to_dyn = function
     | Error -> Dyn.string "error"
     | Warning -> Dyn.string "warning"
+    | Alert -> Dyn.string "alert"
   ;;
 
   let sexp =
@@ -790,9 +792,7 @@ module Compound_user_error = struct
         match report.severity with
         | Error _ -> Error
         | Warning _ -> Warning
-        | Alert _ ->
-          (* FIXME: tests expect this, but it's unclear if that should change. *)
-          Error
+        | Alert _ -> Alert
       in
       make_with_severity ~main ~related ~severity)
   ;;

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
@@ -94,6 +102,7 @@ module Diagnostic : sig
   type severity =
     | Error
     | Warning
+    | Alert
 
   module Promotion : sig
     type t =