fix: include all diagnostics (#6940)

Some compilation commands emit more than one diagnostics. For example,
ocamlc can emit more than one deprecation or unused error warning.

The previous behavior would be to just take the first error and drop the
others. This PR fixes the behavior to include all errors extracted out
of a command.

Signed-off-by: Rudi Grinberg <[email protected]>

src/dune_engine/build_system.ml

@@ -29,57 +29,66 @@ module Error = struct
   module Id = Id.Make ()
 
   type t =
-    { exn : Exn_with_backtrace.t
-    ; id : Id.t
-    }
+    | Exn of
+        { id : Id.t
+        ; exn : Exn_with_backtrace.t
+        }
+    | Diagnostic of
+        { id : Id.t
+        ; diagnostic : Compound_user_error.t
+        ; dir : Path.t option
+        ; promotion : Diff_promotion.Annot.t option
+        }
 
   module Event = struct
     type nonrec t =
       | Add of t
       | Remove of t
   end
 
-  let create ~exn = { exn; id = Id.gen () }
-
-  let id t = t.id
-
-  let promotion t =
-    let e =
-      match t.exn.exn with
-      | Memo.Error.E e -> Memo.Error.get e
-      | e -> e
-    in
-    match e with
-    | User_error.E msg ->
-      User_message.Annots.find msg.annots Diff_promotion.Annot.annot
-    | _ -> None
-
-  type info =
-    { dir : Path.t option
-    ; related : User_message.t list
-    ; main : User_message.t
-    }
-
-  let info (t : t) =
-    let e =
-      match t.exn.exn with
-      | Memo.Error.E e -> Memo.Error.get e
-      | e -> e
+  let of_exn (exn : Exn_with_backtrace.t) =
+    let exn =
+      match exn.exn with
+      | Memo.Error.E e -> { exn with exn = Memo.Error.get e }
+      | _ -> exn
     in
-    match e with
+    match exn.exn with
     | User_error.E main -> (
       let dir =
         User_message.Annots.find main.annots Process.with_directory_annot
       in
+      let promotion =
+        User_message.Annots.find main.annots Diff_promotion.Annot.annot
+      in
       match User_message.Annots.find main.annots Compound_user_error.annot with
-      | None -> { main; related = []; dir }
-      | Some { main; related } -> { main; related; dir })
-    | e ->
-      (* CR-someday jeremiedimino: Use [Report_error.get_user_message] here. *)
-      { main = User_message.make [ Pp.text (Printexc.to_string e) ]
-      ; related = []
-      ; dir = None
-      }
+      | None ->
+        [ Diagnostic
+            { dir
+            ; id = Id.gen ()
+            ; diagnostic = Compound_user_error.make ~main ~related:[]
+            ; promotion
+            }
+        ]
+      | Some diagnostics ->
+        List.map diagnostics ~f:(fun diagnostic ->
+            Diagnostic { id = Id.gen (); diagnostic; dir; promotion }))
+    | _ -> [ Exn { id = Id.gen (); exn } ]
+
+  let promotion = function
+    | Exn _ -> None
+    | Diagnostic d -> d.promotion
+
+  let id = function
+    | Exn d -> d.id
+    | Diagnostic d -> d.id
+
+  let dir = function
+    | Exn _ -> None
+    | Diagnostic d -> d.dir
+
+  let description = function
+    | Exn e -> `Exn e.exn
+    | Diagnostic d -> `Diagnostic d.diagnostic
 
   module Set : sig
     type error := t
@@ -119,9 +128,9 @@ module Error = struct
         true (* only possible when both sets are empty *)
       | Some x, Some y -> (
         match (x, y) with
-        | Add x, Add y -> Id.equal x.id y.id
+        | Add x, Add y -> Id.equal (id x) (id y)
         | Add _, _ -> false
-        | Remove x, Remove y -> Id.equal x.id y.id
+        | Remove x, Remove y -> Id.equal (id x) (id y)
         | Remove _, _ -> false)
       | Some _, None | None, Some _ -> false
 
@@ -189,13 +198,14 @@ module State = struct
 
   let reset_errors () = Svar.write errors Error.Set.empty
 
-  let add_error error =
+  let add_errors error_list =
     let open Fiber.O in
     let* () =
       update_build_progress_exn ~f:(fun p ->
           { p with number_of_rules_failed = p.number_of_rules_failed + 1 })
     in
-    Svar.write errors @@ Error.Set.add (Svar.read errors) error
+    List.fold_left error_list ~init:(Svar.read errors) ~f:Error.Set.add
+    |> Svar.write errors
 end
 
 let rec with_locks ~f = function
@@ -1135,8 +1145,8 @@ let report_early_exn exn =
   | true -> Fiber.return ()
   | false -> (
     let open Fiber.O in
-    let error = Error.create ~exn in
-    let+ () = State.add_error error in
+    let errors = Error.of_exn exn in
+    let+ () = State.add_errors errors in
     match !Clflags.report_errors_config with
     | Early | Twice -> Dune_util.Report_error.report exn
     | Deterministic -> ())

src/dune_engine/build_system.mli

@@ -84,8 +84,6 @@ val state : State.t Fiber.Svar.t
 
 (** Errors found when building targets. *)
 module Error : sig
-  type t
-
   module Id : sig
     type t
 
@@ -98,6 +96,20 @@ module Error : sig
     val to_dyn : t -> Dyn.t
   end
 
+  type t
+
+  val id : t -> Id.t
+
+  (** the directory where the rule the error is originating from *)
+  val dir : t -> Path.t option
+
+  (** The description of the error. Errors from build rules contain useful
+      metadata that are extracted into [`Diagnostic] *)
+  val description :
+    t -> [ `Exn of Exn_with_backtrace.t | `Diagnostic of Compound_user_error.t ]
+
+  val promotion : t -> Diff_promotion.Annot.t option
+
   module Event : sig
     type nonrec t =
       | Add of t
@@ -119,28 +131,6 @@ module Error : sig
 
     val empty : t
   end
-
-  val create : exn:Exn_with_backtrace.t -> t
-
-  (** [info] stores additional information about errors *)
-  type info =
-    { dir : Path.t option
-          (** the directory where the rule the error is originating from *)
-    ; related : User_message.t list
-          (** related errors with additional descriptions and locations. only
-              useful for rpc clients *)
-    ; main : User_message.t
-          (** the main message of the error. this is what is displayed in the
-              console *)
-    }
-
-  (** [info t] returns additional information regarding errors. useful for rich
-      clients that consume errors through rpc *)
-  val info : t -> info
-
-  val promotion : t -> Diff_promotion.Annot.t option
-
-  val id : t -> Id.t
 end
 
 (** The current set of active errors. *)

src/dune_engine/compound_user_error.ml

@@ -34,7 +34,8 @@ let to_dyn { main; related } =
     ; ("related", (list string) (List.map related ~f:User_message.to_string))
     ]
 
-let annot = User_message.Annots.Key.create ~name:"compound-user-error" to_dyn
+let annot =
+  User_message.Annots.Key.create ~name:"compound-user-error" (Dyn.list to_dyn)
 
 let make ~main ~related = create ~main ~related
 
@@ -60,16 +61,13 @@ let make_loc ~dir { Ocamlc_loc.path; chars; lines } : Loc.t =
   }
 
 let parse_output ~dir s =
-  let reports = Ocamlc_loc.parse s in
-  match reports with
-  | [] -> None
-  | report :: _ ->
-    (* We assume that there's at most one error coming from a command for now.*)
-    let make_message (loc, message) =
-      let loc = make_loc ~dir loc in
-      let message = Pp.verbatim message in
-      User_message.make ~loc [ message ]
-    in
-    let main = make_message (report.loc, report.message) in
-    let related = List.map report.related ~f:make_message in
-    Some (make ~main ~related)
+  Ocamlc_loc.parse s
+  |> List.map ~f:(fun (report : Ocamlc_loc.report) ->
+         let make_message (loc, message) =
+           let loc = make_loc ~dir loc in
+           let message = Pp.verbatim message in
+           User_message.make ~loc [ message ]
+         in
+         let main = make_message (report.loc, report.message) in
+         let related = List.map report.related ~f:make_message in
+         make ~main ~related)

src/dune_engine/compound_user_error.mli

@@ -9,8 +9,8 @@ type t = private
   ; related : User_message.t list
   }
 
-val annot : t User_message.Annots.Key.t
+val annot : t list User_message.Annots.Key.t
 
 val make : main:User_message.t -> related:User_message.t list -> t
 
-val parse_output : dir:Path.t -> string -> t option
+val parse_output : dir:Path.t -> string -> t list

src/dune_engine/dune_project.ml

@@ -805,9 +805,10 @@ let parse ~dir ~lang ~file ~dir_status =
                    in
                    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
+                     ]
                  in
                  User_error.raise ~annots
                    (main_message

src/dune_engine/process.ml

@@ -480,8 +480,9 @@ end = struct
               User_message.Annots.has_embedded_location ()
           in
           match Compound_user_error.parse_output ~dir output.without_color with
-          | None -> annots
-          | Some e -> User_message.Annots.set annots Compound_user_error.annot e
+          | [] -> annots
+          | errors ->
+            User_message.Annots.set annots Compound_user_error.annot errors
         else annots
     in
     (loc, annots)

src/dune_engine/sub_dirs.ml

@@ -210,7 +210,7 @@ module Dir_map = struct
                     ]
                   in
                   User_message.Annots.singleton Compound_user_error.annot
-                    (Compound_user_error.make ~main ~related)
+                    [ Compound_user_error.make ~main ~related ]
                 in
                 User_error.raise ~loc ~annots
                   [ main_message; Pp.verbatim (Loc.to_file_colon_line loc2) ]))

src/dune_rpc_impl/diagnostics.ml

@@ -10,6 +10,7 @@ module Conv = Dune_rpc.Conv
 module Dep_conf = Dune_rules.Dep_conf
 module Source_tree = Dune_engine.Source_tree
 module Dune_project = Dune_engine.Dune_project
+module Compound_user_error = Dune_engine.Compound_user_error
 
 let absolutize_paths ~dir (loc : Loc.t) =
   let make_path name =
@@ -25,16 +26,22 @@ let absolutize_paths ~dir (loc : Loc.t) =
 let diagnostic_of_error : Build_system.Error.t -> Dune_rpc_private.Diagnostic.t
     =
  fun m ->
-  let { Build_system.Error.main = message; related; dir } =
-    Build_system.Error.info m
-  in
   let dir =
+    let dir = Build_system.Error.dir m in
     Option.map dir ~f:Path.drop_optional_build_context_maybe_sandboxed
   in
   let make_loc loc =
     let dir = Option.value ~default:Path.root dir in
     absolutize_paths ~dir loc
   in
+  let message, related =
+    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)
+  in
   let loc = Option.map message.loc ~f:make_loc in
   let make_message pars = Pp.map_tags (Pp.concat pars) ~f:(fun _ -> ()) in
   let id =
@@ -58,7 +65,7 @@ let diagnostic_of_error : Build_system.Error.t -> Dune_rpc_private.Diagnostic.t
         ; loc = make_loc (Option.value_exn related.loc)
         })
   in
-  { severity = None
+  { Dune_rpc_private.Diagnostic.severity = None
   ; id
   ; targets = []
   ; message = make_message message.paragraphs

src/dune_rules/foreign.ml

@@ -225,7 +225,7 @@ module Objects = struct
         let main = User_message.make ~loc [ Pp.text main_message ] in
         let related = [ User_message.make ~loc:loc' [ Pp.text "" ] ] in
         User_message.Annots.singleton Compound_user_error.annot
-          (Compound_user_error.make ~main ~related)
+          [ Compound_user_error.make ~main ~related ]
       in
       User_error.raise ~loc ~annots
         [ Pp.textf "%s Already appears at:" main_message

src/dune_rules/foreign_sources.ml

@@ -209,7 +209,7 @@ let make stanzas ~(sources : Foreign.Sources.Unresolved.t) ~dune_version
           ]
         in
         User_message.Annots.singleton Compound_user_error.annot
-          (Compound_user_error.make ~main ~related)
+          [ Compound_user_error.make ~main ~related ]
       in
       User_error.raise ~loc ~annots
         [ Pp.textf "%s. See another definition at %s." main_message
@@ -251,7 +251,7 @@ let make stanzas ~(sources : Foreign.Sources.Unresolved.t) ~dune_version
             [ User_message.make ~loc:loc1 [ Pp.text "Name already used here" ] ]
           in
           User_message.Annots.singleton Compound_user_error.annot
-            (Compound_user_error.make ~main ~related)
+            [ Compound_user_error.make ~main ~related ]
         in
         User_error.raise ~annots ~loc:loc2
           [ Pp.textf "%s; the name has already been taken in %s." main_message

src/dune_rules/ml_sources.ml

@@ -121,7 +121,7 @@ module Modules = struct
                 User_message.make ~loc [ Pp.text "Used in this stanza" ])
           in
           User_message.Annots.singleton Compound_user_error.annot
-            (Compound_user_error.make ~main ~related)
+            [ Compound_user_error.make ~main ~related ]
         in
         User_error.raise ~annots ~loc:(Loc.drop_position loc)
           [ main_message
@@ -356,7 +356,7 @@ let make_lib_modules ~dir ~libs ~lookup_vlib ~(lib : Library.t) ~modules
           ]
         in
         User_message.Annots.singleton Compound_user_error.annot
-          (Compound_user_error.make ~main ~related)
+          [ Compound_user_error.make ~main ~related ]
       in
       User_error.raise ~annots ~loc:loc_include_subdirs [ main_message ]
     | _, _ -> ()

src/dune_rules/scope.ml

@@ -124,7 +124,7 @@ module DB = struct
                     ]
                   in
                   User_message.Annots.singleton Compound_user_error.annot
-                    (Compound_user_error.make ~main ~related)
+                    [ Compound_user_error.make ~main ~related ]
                 in
                 User_error.raise ~annots
                   [ main_message
@@ -200,7 +200,7 @@ module DB = struct
               [ User_message.make ~loc:loc1 [ Pp.text "Already defined here" ] ]
             in
             User_message.Annots.singleton Compound_user_error.annot
-              (Compound_user_error.make ~main ~related)
+              [ Compound_user_error.make ~main ~related ]
           in
           User_error.raise ~annots ~loc:loc2
             [ Pp.textf "Public library %s is defined twice:"