Add [Needs_stack_trace] annotation for user errors (#5047)

In #5025 that introduces directory targets, I need a way to force a user error
to include the stack trace even though it has an embedded location.

This PR makes this possible via the new [Needs_stack_trace] annotation. I
also fix a naming inconsistency and rename [has_embed_location] to
[has_embedded_location].

Signed-off-by: Andrey Mokhov <[email protected]>

Author: snowleopard

otherlibs/stdune-unstable/user_error.ml

@@ -40,6 +40,12 @@ module Annot = struct
 
     let to_dyn = Unit.to_dyn
   end)
+
+  module Needs_stack_trace = Make (struct
+    type payload = unit
+
+    let to_dyn = Unit.to_dyn
+  end)
 end
 
 exception E of User_message.t * Annot.t list
@@ -58,12 +64,16 @@ let is_loc_none loc =
   | None -> true
   | Some loc -> loc = Loc0.none
 
-let has_embed_location annots =
+let has_embedded_location annots =
   List.exists annots ~f:(fun annot ->
       Annot.Has_embedded_location.check annot (fun () -> true) (fun () -> false))
 
 let has_location (msg : User_message.t) annots =
-  (not (is_loc_none msg.loc)) || has_embed_location annots
+  (not (is_loc_none msg.loc)) || has_embedded_location annots
+
+let needs_stack_trace annots =
+  List.exists annots ~f:(fun annot ->
+      Annot.Needs_stack_trace.check annot (fun () -> true) (fun () -> false))
 
 let () =
   Printexc.register_printer (function

otherlibs/stdune-unstable/user_error.mli

@@ -19,6 +19,9 @@ module Annot : sig
 
   (** The message has a location embed in the text. *)
   module Has_embedded_location : S with type payload = unit
+
+  (** The message needs a stack trace for clarity. *)
+  module Needs_stack_trace : S with type payload = unit
 end
 
 (** User errors are errors that users need to fix themselves in order to make
@@ -48,10 +51,12 @@ val make :
 (** The "Error:" prefix *)
 val prefix : User_message.Style.t Pp.t
 
-(** Returns [true] if the message has an explicit location or one embed in the
-    text. *)
+(** Returns [true] if the message has an explicit location or one embedded in
+    the text. *)
 val has_location : User_message.t -> Annot.t list -> bool
 
-(** Returns [true] if the following list of annotations contains
-    [Annot.Has_embedded_location]. *)
-val has_embed_location : Annot.t list -> bool
+(** Returns [true] if the list contains [Annot.Has_embedded_location]. *)
+val has_embedded_location : Annot.t list -> bool
+
+(** Returns [true] if the list contains [Annot.Needs_stack_trace]. *)
+val needs_stack_trace : Annot.t list -> bool

src/dune_util/report_error.ml

@@ -10,6 +10,7 @@ type error =
   { responsible : who_is_responsible_for_the_error
   ; msg : User_message.t
   ; has_embedded_location : bool
+  ; needs_stack_trace : bool
   }
 
 let code_error ~loc ~dyn_without_loc =
@@ -25,6 +26,7 @@ let code_error ~loc ~dyn_without_loc =
         ; Pp.box ~indent:2 (Pp.verbatim "  " ++ Dyn.pp dyn_without_loc)
         ]
   ; has_embedded_location = false
+  ; needs_stack_trace = false
   }
 
 let get_error_from_exn = function
@@ -59,10 +61,12 @@ let get_error_from_exn = function
             ; Pp.chain cycle ~f:(fun p -> p)
             ]
       ; has_embedded_location = false
+      ; needs_stack_trace = false
       })
   | User_error.E (msg, annots) ->
-    let has_embedded_location = User_error.has_embed_location annots in
-    { responsible = User; msg; has_embedded_location }
+    let has_embedded_location = User_error.has_embedded_location annots in
+    let needs_stack_trace = User_error.needs_stack_trace annots in
+    { responsible = User; msg; has_embedded_location; needs_stack_trace }
   | Code_error.E e ->
     code_error ~loc:e.loc ~dyn_without_loc:(Code_error.to_dyn_without_loc e)
   | Unix.Unix_error (err, func, fname) ->
@@ -71,11 +75,13 @@ let get_error_from_exn = function
         User_error.make
           [ Pp.textf "%s: %s: %s" func fname (Unix.error_message err) ]
     ; has_embedded_location = false
+    ; needs_stack_trace = false
     }
   | Sys_error msg ->
     { responsible = User
     ; msg = User_error.make [ Pp.text msg ]
     ; has_embedded_location = false
+    ; needs_stack_trace = false
     }
   | exn ->
     let open Pp.O in
@@ -96,6 +102,7 @@ let get_error_from_exn = function
     { responsible = Developer
     ; msg = User_message.make ?loc [ pp ]
     ; has_embedded_location = Option.is_some loc
+    ; needs_stack_trace = false
     }
 
 let i_must_not_crash =
@@ -143,7 +150,9 @@ let report { Exn_with_backtrace.exn; backtrace } =
   match exn with
   | Already_reported -> ()
   | _ ->
-    let { responsible; msg; has_embedded_location } = get_error_from_exn exn in
+    let { responsible; msg; has_embedded_location; needs_stack_trace } =
+      get_error_from_exn exn
+    in
     let msg =
       if msg.loc = Some Loc.none then
         { msg with loc = None }
@@ -163,7 +172,7 @@ let report { Exn_with_backtrace.exn; backtrace } =
              ~f:(fun line -> Pp.box ~indent:2 (Pp.text line)))
     in
     let memo_stack =
-      if !print_memo_stacks then
+      if !print_memo_stacks || needs_stack_trace then
         memo_stack
       else
         match msg.loc with