feature: diagnostic events in the trace

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

Author: rgrinberg

bin/common.ml

@@ -1257,7 +1257,16 @@ let build (root : Workspace_root.t) (builder : Builder.t) =
         match Sys.getenv_opt "DUNE_TRACE" with
         | None ->
           Dune_trace.Category.
-            [ Sandbox; Persistent; Process; Rules; Pkg; Promote; Build; File_watcher ]
+            [ Sandbox
+            ; Persistent
+            ; Process
+            ; Rules
+            ; Pkg
+            ; Promote
+            ; Build
+            ; File_watcher
+            ; Diagnostics
+            ]
         | Some s ->
           String.split ~on:',' s
           |> List.map ~f:(fun x ->

doc/changes/added/13041.md

@@ -0,0 +1 @@
+- Add diagnostic events to the trace. (#13041, @rgrinberg)

src/dune_trace/category.ml

@@ -15,6 +15,7 @@ type t =
   | Debug
   | Config
   | File_watcher
+  | Diagnostics
 
 let all =
   [ Rpc
@@ -31,6 +32,7 @@ let all =
   ; Debug
   ; Config
   ; File_watcher
+  ; Diagnostics
   ]
 ;;
 
@@ -49,6 +51,7 @@ let to_string = function
   | Debug -> "debug"
   | Config -> "config"
   | File_watcher -> "file_watcher"
+  | Diagnostics -> "diagnostics"
 ;;
 
 let of_string =
@@ -79,5 +82,6 @@ module Set = Bit_set.Make (struct
       | Debug -> 11
       | Config -> 12
       | File_watcher -> 13
+      | Diagnostics -> 14
     ;;
   end)

src/dune_trace/category.mli

@@ -13,6 +13,7 @@ type t =
   | Debug
   | Config
   | File_watcher
+  | Diagnostics
 
 val to_string : t -> string
 val of_string : string -> t option

src/dune_trace/dune_trace.mli

@@ -16,6 +16,7 @@ module Category : sig
     | Debug
     | Config
     | File_watcher
+    | Diagnostics
 
   val of_string : string -> t option
 end
@@ -95,6 +96,13 @@ module Event : sig
        ]
     -> t
 
+  val error
+    :  Loc.t option
+    -> [< `Fatal | `User ]
+    -> Printexc.raw_backtrace option
+    -> Dyn.t list
+    -> t
+
   module Rpc : sig
     type stage =
       [ `Start

src/dune_trace/event.ml

@@ -368,3 +368,35 @@ let file_watcher event =
   in
   Event.instant ~name ~args now File_watcher
 ;;
+
+let rec json_of_sexp : Sexp.t -> Json.t = function
+  | Atom s -> Json.string s
+  | List xs -> Json.list (List.map ~f:json_of_sexp xs)
+;;
+
+let error loc kind backtrace memo_stack =
+  let now = Time.now () in
+  let name =
+    match kind with
+    | `User -> "user"
+    | `Fatal -> "fatal"
+  in
+  let loc =
+    Option.map loc ~f:(fun loc -> "loc", Json.string (Loc.to_file_colon_line loc))
+  in
+  let memo_stack =
+    match memo_stack with
+    | [] -> None
+    | frames ->
+      let frames =
+        List.map frames ~f:(fun dyn -> json_of_sexp (Sexp.of_dyn dyn)) |> Json.list
+      in
+      Some ("memo", frames)
+  in
+  let backtrace =
+    Option.map backtrace ~f:(fun bt ->
+      "backtrace", Json.string (Printexc.raw_backtrace_to_string bt))
+  in
+  let args = List.filter_opt [ loc; memo_stack; backtrace ] in
+  Event.instant ~name ~args now Diagnostics
+;;

src/dune_util/report_error.ml

@@ -191,6 +191,21 @@ let gen_report
          | Developer -> i_must_not_crash ())
       ]
   in
+  let () =
+    try
+      Dune_trace.emit Diagnostics (fun () ->
+        Dune_trace.Event.error
+          loc
+          (match responsible with
+           | User -> `User
+           | Developer -> `Fatal)
+          backtrace
+          (List.map memo_stack ~f:Memo.Stack_frame.to_dyn))
+    with
+    | _ ->
+      (* We don't want a failure to write to the trace raise another event *)
+      ()
+  in
   Dune_console.print_user_message { msg with loc; paragraphs }
 ;;