Improve 'required_by ...' messages

src/artifacts.ml

@@ -58,7 +58,7 @@ let binary t name =
               die "Program %s not found in the tree or in the PATH" name
           }
 
-let file_of_lib ?(use_provides=false) t ~lib ~file =
+let file_of_lib ?(use_provides=false) t ~from ~lib ~file =
   match String_map.find lib t.local_libs with
   | Some { package; sub_dir; _ } ->
     let lib_install_dir =
@@ -71,7 +71,9 @@ let file_of_lib ?(use_provides=false) t ~lib ~file =
     in
     Ok (Path.relative lib_install_dir file)
   | None ->
-    match Findlib.find t.context.findlib lib with
+    match
+      Findlib.find t.context.findlib lib ~required_by:[Utils.jbuild_name_in ~dir:from]
+    with
     | Some pkg ->
       Ok (Path.relative pkg.dir file)
     | None ->
@@ -85,5 +87,7 @@ let file_of_lib ?(use_provides=false) t ~lib ~file =
       | None ->
         Error
           { fail = fun () ->
-              die "Library %s not found in the tree or in the PATH" lib
+              die
+                "Library %s not found in the tree or in the installed world"
+                lib
           }

src/artifacts.mli

@@ -11,6 +11,7 @@ val binary : t -> string -> (Path.t, fail) result
 val file_of_lib
   :  ?use_provides:bool
   -> t
+  -> from:Path.t
   -> lib:string
   -> file:string
   -> (Path.t, fail) result

src/config.mli

@@ -10,3 +10,4 @@ val local_install_man_dir : context:string -> Path.t
 val local_install_lib_dir : context:string -> package:string -> Path.t
 
 val dev_null : Path.t
+

src/findlib.ml

@@ -242,7 +242,8 @@ let root_package_name s =
   | None -> s
   | Some i -> String.sub s ~pos:0 ~len:i
 
-let rec load_meta_rec t root_name ~packages ~required_by =
+let rec load_meta_rec t ~fq_name ~packages ~required_by =
+  let root_name = root_package_name fq_name in
   if String_map.mem root_name packages ||
      Hashtbl.mem t.packages root_name then
     packages
@@ -263,6 +264,12 @@ let rec load_meta_rec t root_name ~packages ~required_by =
         match String_map.find root_name Meta.builtins with
         | Some meta -> (t.stdlib_dir, meta)
         | None ->
+          let required_by =
+            if root_name = fq_name then
+              required_by
+            else
+              fq_name :: required_by
+          in
           raise (Package_not_found { package = root_name
                                    ; required_by
                                    })
@@ -277,17 +284,16 @@ let rec load_meta_rec t root_name ~packages ~required_by =
       List.fold_left new_packages ~init:String_map.empty
         ~f:(fun acc (pkg : Pkg_step1.t) ->
           if pkg.exists then
-            let add_roots acc deps =
+            let add_deps acc deps =
               List.fold_left deps ~init:acc ~f:(fun acc dep ->
-                String_map.add acc ~key:(root_package_name dep)
+                String_map.add acc ~key:dep ~data:pkg.package.name)
-                  ~data:pkg.package.name)
             in
-            add_roots (add_roots acc pkg.requires) pkg.ppx_runtime_deps
+            add_deps (add_deps acc pkg.requires) pkg.ppx_runtime_deps
           else
             acc)
     in
     String_map.fold deps ~init:packages ~f:(fun ~key:dep ~data:package packages ->
-      load_meta_rec t dep ~packages ~required_by:(package :: required_by))
+      load_meta_rec t ~fq_name:dep ~packages ~required_by:(package :: required_by))
 
 module Local_closure =
   Top_closure.Make
@@ -316,8 +322,8 @@ let remove_dups_preserve_order pkgs =
   loop String_set.empty pkgs []
 ;;
 
-let load_meta t root_name ~required_by =
+let load_meta t ~fq_name ~required_by =
-  let packages = load_meta_rec t root_name ~packages:String_map.empty ~required_by in
+  let packages = load_meta_rec t ~fq_name ~packages:String_map.empty ~required_by in
   match Local_closure.top_closure packages (String_map.values packages) with
   | Error cycle ->
     die "dependency cycle detected between external findlib packages:\n   %s"
@@ -389,12 +395,12 @@ let load_meta t root_name ~required_by =
       end
     )
 
-let find_exn t name =
+let find_exn t ~required_by name =
   match Hashtbl.find t.packages name with
   | Some (Present x) -> x
   | Some (Absent pnf) -> raise (Package_not_found pnf)
   | None ->
-    match load_meta t (root_package_name name) ~required_by:[] with
+    match load_meta t ~fq_name:name ~required_by with
     | exception (Package_not_found pnf as e) ->
       Hashtbl.add t.packages ~key:name ~data:(Absent pnf);
       raise e
@@ -407,14 +413,14 @@ let find_exn t name =
         let pnf =
           { Package_not_found.
             package     = name
-          ; required_by = []
+          ; required_by
           }
         in
         Hashtbl.add t.packages ~key:name ~data:(Absent pnf);
         raise (Package_not_found pnf)
 
-let find t name =
+let find t ~required_by name =
-  match find_exn t name with
+  match find_exn t ~required_by name with
   | exception (Package_not_found _) -> None
   | x -> Some x
 
@@ -449,7 +455,7 @@ let root_packages t =
 
 let all_packages t =
   List.iter (root_packages t) ~f:(fun pkg ->
-    ignore (find_exn t pkg : package));
+    ignore (find_exn t pkg ~required_by:[] : package));
   Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:_ ~data acc ->
     match data with
     | Present p -> p :: acc

src/findlib.mli

@@ -31,8 +31,8 @@ type package =
   ; has_headers      : bool
   }
 
-val find     : t -> string -> package option
+val find     : t -> required_by:string list -> string -> package option
-val find_exn : t -> string -> package
+val find_exn : t -> required_by:string list -> string -> package
 
 val available : t -> string -> bool
 

src/gen_rules.ml

@@ -265,7 +265,7 @@ module Gen(P : Params) = struct
             "invalid ${lib:...} form: %s" name
         | Some x -> x
       in
-      (lib, file_of_lib t ~lib ~file ?use_provides)
+      (lib, file_of_lib t ~from:dir ~lib ~file ?use_provides)
 
     (* Hides [t] so that we don't resolve things statically *)
     let t = ()

src/jbuild_load.ml

@@ -83,7 +83,8 @@ end
             ~target:generated_jbuild
         in
         let pkgs =
-          List.map requires ~f:(Findlib.find_exn context.findlib)
+          List.map requires ~f:(Findlib.find_exn context.findlib
+                                  ~required_by:[Utils.jbuild_name_in ~dir:dir])
           |> Findlib.closure
         in
         let includes =

src/lib_db.ml

@@ -32,7 +32,8 @@ let find_exn t ~from name =
   | None ->
     Hashtbl.find_or_add t.by_public_name name
       ~f:(fun name ->
-        External (Findlib.find_exn t.findlib name))
+        External (Findlib.find_exn t.findlib name
+                    ~required_by:[Utils.jbuild_name_in ~dir:from]))
 
 let find t ~from name =
   match find_exn t ~from name with

src/utils.ml

@@ -57,3 +57,12 @@ let signal_name =
     match List.assoc n table with
     | exception Not_found -> sprintf "%d\n" n
     | s -> s
+
+let jbuild_name_in ~dir =
+  match Path.extract_build_context dir with
+  | None ->
+    Path.to_string (Path.relative dir "jbuild")
+  | Some (ctx_name, dir) ->
+    sprintf "%s (context %s)"
+      (Path.to_string (Path.relative dir "jbuild"))
+      ctx_name

src/utils.mli

@@ -8,3 +8,6 @@ val system_shell : needed_to:string -> Path.t * string * fail option
 
 (** Convert a signal number to a name: INT, TERM, ... *)
 val signal_name : int -> string
+
+(** Return the path to the jbuild file in this directory as a string. *)
+val jbuild_name_in : dir:Path.t -> string