Show the context name for errors happening in "alt" contexts (ocaml#1…

…0414)

* test: add sample for multi-context error

Signed-off-by: Javier Chávarri <javier.chavarri@gmail.com>

doc/changes/10414.md

@@ -0,0 +1,2 @@
+- Show the context name for errors happening in non-default contexts.
+  (#10414, @jchavarri)

otherlibs/stdune/src/user_message.ml

@@ -173,9 +173,11 @@ type t =
   ; paragraphs : Style.t Pp.t list
   ; hints : Style.t Pp.t list
   ; annots : Annots.t
+  ; context : string option
+  ; dir : string option
   }
 
-let compare { loc; paragraphs; hints; annots } t =
+let compare { loc; paragraphs; hints; annots; context = _; dir = _ } t =
   let open Ordering.O in
   let= () = Option.compare Loc0.compare loc t.loc in
   let= () = List.compare paragraphs t.paragraphs ~compare:Poly.compare in
@@ -185,17 +187,17 @@ let compare { loc; paragraphs; hints; annots } t =
 
 let equal a b = Ordering.is_eq (compare a b)
 
-let make ?loc ?prefix ?(hints = []) ?(annots = Annots.empty) paragraphs =
+let make ?loc ?prefix ?(hints = []) ?(annots = Annots.empty) ?context ?dir paragraphs =
   let paragraphs =
     match prefix, paragraphs with
     | None, l -> l
     | Some p, [] -> [ p ]
     | Some p, x :: l -> Pp.concat ~sep:Pp.space [ p; x ] :: l
   in
-  { loc; hints; paragraphs; annots }
+  { loc; hints; paragraphs; annots; context; dir }
 ;;
 
-let pp { loc; paragraphs; hints; annots = _ } =
+let pp { loc; paragraphs; hints; annots = _; context; dir = _ } =
   let open Pp.O in
   let paragraphs =
     match hints with
@@ -226,6 +228,12 @@ let pp { loc; paragraphs; hints; annots = _ } =
            (Pp.textf "File %S, %s, characters %d-%d:" start.pos_fname lnum start_c stop_c))
       :: paragraphs
   in
+  let paragraphs =
+    match context with
+    | None | Some "default" | Some ".sandbox" -> paragraphs
+    | Some context ->
+      Pp.box (Pp.tag Style.Loc (Pp.textf "Context: %s" context)) :: paragraphs
+  in
   Pp.vbox (Pp.concat_map paragraphs ~sep:Pp.nop ~f:(fun pp -> Pp.seq pp Pp.cut))
 ;;
 

otherlibs/stdune/src/user_message.mli

@@ -66,6 +66,8 @@ type t =
   ; paragraphs : Style.t Pp.t list
   ; hints : Style.t Pp.t list
   ; annots : Annots.t
+  ; context : string option
+  ; dir : string option
   }
 
 val compare : t -> t -> Ordering.t
@@ -90,6 +92,8 @@ val make
   -> ?prefix:Style.t Pp.t
   -> ?hints:Style.t Pp.t list
   -> ?annots:Annots.t
+  -> ?context:string
+  -> ?dir:string
   -> Style.t Pp.t list
   -> t
 

src/dune_console/dune_console.ml

@@ -30,6 +30,8 @@ let blank_line_msg =
   ; hints = []
   ; annots = User_message.Annots.empty
   ; loc = None
+  ; context = None
+  ; dir = None
   }
 ;;
 

src/dune_engine/action_runner.ml

@@ -27,7 +27,7 @@ end = struct
               (* Compound user errors do not contain annotations, so it's fine to
                  marshal them as is. *)
           ; diff_promotion : Diff_promotion.Annot.t option
-          ; with_directory : Path.t option
+          ; with_directory : string option
           }
       | Code of Code_error.t
       | Sys of string
@@ -67,17 +67,13 @@ end = struct
           | Some annot -> User_message.Annots.set annots Diff_promotion.Annot.annot annot
           | None -> annots
         in
-        let annots =
-          match with_directory with
-          | Some annot ->
-            User_message.Annots.set annots Process.with_directory_annot annot
-          | None -> annots
-        in
         User
           { loc = message.loc
           ; paragraphs = message.paragraphs
           ; hints = message.hints
           ; annots
+          ; context = None
+          ; dir = with_directory
           }
       | Code err -> Code err
       | Sys err -> Sys err
@@ -106,9 +102,7 @@ end = struct
           User_message.Annots.find annots Compound_user_error.annot
         in
         let diff_promotion = User_message.Annots.find annots Diff_promotion.Annot.annot in
-        let with_directory =
-          User_message.Annots.find annots Process.with_directory_annot
-        in
+        let with_directory = message.dir in
         User_with_annots
           { message
           ; has_embedded_location

src/dune_engine/build_system_error.ml

@@ -27,7 +27,7 @@ let of_exn (exn : Exn_with_backtrace.t) =
   in
   match exn.exn with
   | User_error.E main ->
-    let dir = User_message.Annots.find main.annots Process.with_directory_annot in
+    let dir = Option.map ~f:Path.of_string main.dir 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 ->

src/dune_engine/process.ml

@@ -6,10 +6,6 @@ module Timestamp = Event.Timestamp
 module Action_output_on_success = Execution_parameters.Action_output_on_success
 module Action_output_limit = Execution_parameters.Action_output_limit
 
-let with_directory_annot =
-  User_message.Annots.Key.create ~name:"with-directory" Path.to_dyn
-;;
-
 let limit_output = Dune_output_truncation.limit_output ~message:"TRUNCATED BY DUNE"
 
 module Failure_mode = struct
@@ -529,10 +525,9 @@ end = struct
       Has_output { with_color; without_color; has_embedded_location }
   ;;
 
-  let get_loc_and_annots ~dir ~metadata ~output =
+  let get_loc_annots_and_dir ~dir ~metadata ~output =
     let { loc; annots; _ } = metadata in
     let dir = Option.value dir ~default:Path.root in
-    let annots = User_message.Annots.set annots with_directory_annot dir in
     let annots =
       match output with
       | No_output -> annots
@@ -547,14 +542,15 @@ end = struct
           | errors -> User_message.Annots.set annots Compound_user_error.annot errors)
         else annots
     in
-    loc, annots
+    loc, annots, dir
   ;;
 
-  let fail ~loc ~annots paragraphs =
+  let fail ?dir ~loc ~annots paragraphs =
     (* We don't use [User_error.make] as it would add the "Error: " prefix. We
        don't need this prefix as it is already included in the output of the
        command. *)
-    raise (User_error.E (User_message.make ?loc ~annots paragraphs))
+    let dir = Option.map ~f:Path.to_string dir in
+    raise (User_error.E (User_message.make ?dir ?loc ~annots paragraphs))
   ;;
 
   let verbose t ~id ~metadata ~output ~command_line ~dir =
@@ -579,8 +575,9 @@ end = struct
         | Failed n -> sprintf "exited with code %d" n
         | Signaled signame -> sprintf "got signal %s" (Signal.name signame)
       in
-      let loc, annots = get_loc_and_annots ~dir ~metadata ~output in
+      let loc, annots, dir = get_loc_annots_and_dir ~dir ~metadata ~output in
       fail
+        ~dir
         ~loc
         ~annots
         ((Pp.tag User_message.Style.Kwd (Pp.verbatim "Command")
@@ -635,7 +632,7 @@ end = struct
       then Console.print_user_message (User_message.make paragraphs);
       n
     | Error error ->
-      let loc, annots = get_loc_and_annots ~dir ~metadata ~output in
+      let loc, annots, dir = get_loc_annots_and_dir ~dir ~metadata ~output in
       let paragraphs =
         match verbosity with
         | Short ->
@@ -658,7 +655,7 @@ end = struct
                 | Signaled signame ->
                   [ Pp.textf "Command got signal %s." (Signal.name signame) ]))
       in
-      fail ~loc ~annots paragraphs
+      fail ~dir ~loc ~annots paragraphs
   ;;
 end
 

src/dune_engine/process.mli

@@ -4,8 +4,6 @@ open Import
 module Action_output_on_success := Execution_parameters.Action_output_on_success
 module Action_output_limit := Execution_parameters.Action_output_limit
 
-val with_directory_annot : Path.t User_message.Annots.Key.t
-
 module Failure_mode : sig
   (** How to handle sub-process failures *)
   type ('a, 'b) t =

src/dune_util/report_error.ml

@@ -63,6 +63,15 @@ let get_error_from_exn = function
   | User_error.E msg ->
     let has_embedded_location = User_message.has_embedded_location msg in
     let needs_stack_trace = User_message.needs_stack_trace msg in
+    let msg =
+      match msg.dir with
+      | None -> msg
+      | Some path ->
+        let build_context = Path.extract_build_context (Path.of_string path) in
+        (match build_context with
+         | None -> msg
+         | Some (ctxt, _) -> { msg with context = Some ctxt })
+    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)

test/blackbox-tests/test-cases/multi-context-error.t

@@ -0,0 +1,39 @@
+  $ cat > dune-project << EOF
+  > (lang dune 3.15)
+  > (using melange 0.1)
+  > (package (name bar) (allow_empty))
+  > (package (name baz) (allow_empty))
+  > EOF
+
+  $ cat > dune-workspace << EOF
+  > (lang dune 3.15)
+  > 
+  > (context default)
+  > 
+  > (context
+  >  (default
+  >   (name melange)))
+  > EOF
+  $ cat > dune << EOF
+  > (library
+  >  (name foo)
+  >  (public_name bar.foo)
+  >  (enabled_if (= %{context_name} "default")))
+  > (library
+  >  (name foo)
+  >  (public_name baz.foo)
+  >  (modes melange)
+  >  (enabled_if (= %{context_name} "melange")))
+  > EOF
+
+  $ cat > foo.ml <<EOF
+  > let t = Str.regexp
+  > EOF
+
+  $ dune build
+  Context: melange
+  File "foo.ml", line 1, characters 8-18:
+  1 | let t = Str.regexp
+              ^^^^^^^^^^
+  Error: Unbound module Str
+  [1]