Replace Dep_path by a more principled mechanism (#4605)

Signed-off-by: Jeremie Dimino <[email protected]>

bin/common.ml

@@ -175,7 +175,7 @@ let init ?log_file c =
     ~cache_debug_flags:c.cache_debug_flags
     ~handler:(Option.map c.rpc ~f:Dune_rpc_impl.Server.build_handler);
   Only_packages.Clflags.set c.only_packages;
-  Clflags.debug_dep_path := c.debug_dep_path;
+  Dune_util.Report_error.print_memo_stacks := c.debug_dep_path;
   Clflags.debug_findlib := c.debug_findlib;
   Clflags.debug_backtraces c.debug_backtraces;
   Clflags.debug_artifact_substitution := c.debug_artifact_substitution;

bin/main.ml

@@ -93,5 +93,5 @@ let () =
   | Scheduler.Run.Shutdown_requested -> exit 0
   | exn ->
     let exn = Exn_with_backtrace.capture exn in
-    Dune_engine.Report_error.report exn;
+    Dune_util.Report_error.report exn;
     exit 1

otherlibs/action-plugin/test/depends-on-its-target-by-read-dir/run.t

@@ -13,7 +13,7 @@
   $ cp ./bin/foo.exe ./
 
   $ dune build some_file
-  Error: Dependency cycle between the following files:
+  Error: Dependency cycle between:
      _build/default/some_file
   [1]
 

otherlibs/action-plugin/test/depends-on-its-target/run.t

@@ -19,11 +19,11 @@
   $ cp ./bin/foo2.exe ./
 
   $ dune build some_file1
-  Error: Dependency cycle between the following files:
+  Error: Dependency cycle between:
      _build/default/some_file1
   [1]
 
   $ dune build some_file2
-  Error: Dependency cycle between the following files:
+  Error: Dependency cycle between:
      _build/default/some_file2
   [1]

otherlibs/site/src/plugins/meta_parser.ml

@@ -34,7 +34,7 @@ module Meta_parser = Dune_meta_parser.Meta_parser.Make (struct
       type t = unit
     end
 
-    let raise ?loc:_ ?hints:_ ?annot:_ texts =
+    let raise ?loc:_ ?hints:_ ?annots:_ texts =
       invalid_arg (String.concat " " texts)
   end
 end)

otherlibs/stdune-unstable/user_error.ml

@@ -34,24 +34,47 @@ module Annot = struct
       in
       format := f
   end
+
+  module Has_embedded_location = Make (struct
+    type payload = unit
+
+    let to_dyn = Unit.to_dyn
+  end)
 end
 
-exception E of User_message.t * Annot.t option
+exception E of User_message.t * Annot.t list
 
 let prefix =
   Pp.seq (Pp.tag User_message.Style.Error (Pp.verbatim "Error")) (Pp.char ':')
 
 let make ?loc ?hints paragraphs =
   User_message.make ?loc ?hints paragraphs ~prefix
 
-let raise ?loc ?hints ?annot paragraphs =
-  raise (E (make ?loc ?hints paragraphs, annot))
+let raise ?loc ?hints ?(annots = []) paragraphs =
+  raise (E (make ?loc ?hints paragraphs, annots))
+
+let is_loc_none loc =
+  match loc with
+  | None -> true
+  | Some loc -> loc = Loc0.none
+
+let has_embed_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
 
 let () =
   Printexc.register_printer (function
-    | E (t, None) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t))
-    | E (t, Some annot) ->
-      Some
-        (Format.asprintf "%a (annotations: %a)@?" Pp.to_fmt (User_message.pp t)
-           Pp.to_fmt (!Annot.format annot))
+    | E (t, []) -> Some (Format.asprintf "%a@?" Pp.to_fmt (User_message.pp t))
+    | E (t, annots) ->
+      let open Pp.O in
+      let pp =
+        User_message.pp t
+        ++ Pp.vbox
+             (Pp.concat_map annots ~f:(fun annot ->
+                  Pp.box (!Annot.format annot) ++ Pp.cut))
+      in
+      Some (Format.asprintf "%a" Pp.to_fmt pp)
     | _ -> None)

otherlibs/stdune-unstable/user_error.mli

@@ -16,6 +16,9 @@ module Annot : sig
 
     val to_dyn : payload -> Dyn.t
   end) : S with type payload = M.payload
+
+  (** The message has a location embed in the text. *)
+  module Has_embedded_location : S with type payload = unit
 end
 
 (** User errors are errors that users need to fix themselves in order to make
@@ -24,14 +27,14 @@ end
 
     The additional [Annot.t] is intended to carry extra context for other,
     non-user-facing purposes (such as data for the RPC). *)
-exception E of User_message.t * Annot.t option
+exception E of User_message.t * Annot.t list
 
 (** Raise a user error. The arguments are interpreted in the same way as
     [User_message.make]. The first paragraph is prefixed with "Error:". *)
 val raise :
      ?loc:Loc0.t
   -> ?hints:User_message.Style.t Pp.t list
-  -> ?annot:Annot.t
+  -> ?annots:Annot.t list
   -> User_message.Style.t Pp.t list
   -> _
 
@@ -44,3 +47,11 @@ 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. *)
+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

src/dune_engine/action.ml

@@ -30,7 +30,7 @@ module Prog = struct
       in
       Utils.program_not_found_message ?hint ~loc ~context program
 
-    let raise t = raise (User_error.E (user_message t, None))
+    let raise t = raise (User_error.E (user_message t, []))
 
     let to_dyn { context; program; hint; loc = _ } =
       let open Dyn.Encoder in

src/dune_engine/action_builder.ml

@@ -381,13 +381,7 @@ struct
         | true -> exec then_
         | false -> exec else_)
       | Catch (t, on_error) -> (
-        let+ res =
-          Memo.Build.map_reduce_errors
-            (module Monoid.Unit)
-            ~on_error:(fun _ -> Memo.Build.return ())
-            (fun () -> exec t)
-        in
-        match res with
+        Memo.Build.swallow_errors (fun () -> exec t) >>| function
         | Ok r -> r
         | Error () -> (on_error, Dep.Map.empty))
       | Memo m -> Memo_poly.eval m