Print resolved external library dependencies

Adding '--external-lib-deps' flag in order to print all resolved library
dependencies. It's motivated by opam-dune-lint.

opam-dune-lint is using 'external-lib-deps' subcommand which is removed
on the previous version ocaml#4298.

Signed-off-by: Alpha DIALLO <[email protected]>

bin/build_cmd.ml

@@ -55,6 +55,12 @@ let run_build_system ~common ~request =
             ())
       in
       let* res = run ~toplevel in
+      let* ()  =
+        match Common.external_lib_deps common with
+        | Some `Normal -> Fiber.return (Console.print_user_message (Lib_resolved.External_libs.print ()))
+        | Some `Sexp   -> Fiber.return (Console.print_user_message (Lib_resolved.External_libs.sexp ()))
+        | None -> Fiber.return ()
+      in
       let+ () =
         match Common.dump_memo_graph_file common with
         | None -> Fiber.return ()

bin/common.ml

@@ -50,6 +50,7 @@ type t =
   ; report_errors_config : Dune_engine.Report_errors_config.t
   ; require_dune_project_file : bool
   ; insignificant_changes : [ `React | `Ignore ]
+  ; external_lib_deps : [ `Sexp | `Normal ] option
   }
 
 let capture_outputs t = t.capture_outputs
@@ -78,6 +79,8 @@ let stats t = t.stats
 
 let insignificant_changes t = t.insignificant_changes
 
+let external_lib_deps t = t.external_lib_deps
+
 let set_print_directory t b = { t with no_print_directory = not b }
 
 let set_promote t v = { t with promote = Some v }
@@ -980,6 +983,14 @@ let term ~default_root_is_cwd =
              $(b,twice) - report each error twice: once as soon as the error \
              is discovered and then again at the end of the build, in a \
              deterministic order.")
+  and+ external_lib_deps =
+    Arg.(
+      value
+      & opt ~vopt:(Some `Normal) (some (enum [("sexp",`Sexp);("normal",`Normal)])) None
+      & info ["external-lib-deps"]
+        ~doc:
+            "Print all resolved external dependency libraries. \
+            $(b,--external-lib-deps=sexp) - to print in S-expression format")
   and+ react_to_insignificant_changes =
     Arg.(
       value & flag
@@ -1047,6 +1058,7 @@ let term ~default_root_is_cwd =
   ; report_errors_config
   ; require_dune_project_file
   ; insignificant_changes
+  ; external_lib_deps
   }
 
 let term_with_default_root_is_cwd = term ~default_root_is_cwd:true

bin/common.mli

@@ -71,6 +71,8 @@ val build_info : unit Cmdliner.Term.t
 
 val default_build_dir : string
 
+val external_lib_deps : t -> [ `Sexp | `Normal ] option
+
 module Let_syntax : sig
   val ( let+ ) : 'a Cmdliner.Term.t -> ('a -> 'b) -> 'b Cmdliner.Term.t
 

bin/import.ml

@@ -32,6 +32,7 @@ module Resolve = Dune_rules.Resolve
 module Log = Dune_util.Log
 module Dune_rpc = Dune_rpc_private
 module Graph = Dune_graph.Graph
+module Lib_resolved = Dune_rules.Lib_resolved
 include Common.Let_syntax
 
 let in_group (t, info) = (Term.Group.Term t, info)

src/dune_rules/dune_rules.ml

@@ -44,6 +44,7 @@ module Command = Command
 module Install = Install
 module Lib_name = Lib_name
 module Diff = Dune_lang.Action.Diff
+module Lib_resolved = Lib_resolved
 
 module Install_rules = struct
   let install_file = Install_rules.install_file

src/dune_rules/lib.ml

@@ -369,12 +369,17 @@ module Status = struct
     | Found t -> variant "Found" [ to_dyn t ]
 end
 
+module Kind_db = struct
+  type t = Installed_libs | Public_libs | Project_libs
+end
+
 type db =
   { parent : db option
   ; resolve : Lib_name.t -> resolve_result Memo.t
   ; all : Lib_name.t list Memo.Lazy.t
   ; lib_config : Lib_config.t
   ; instrument_with : Lib_name.t list
+  ; kind: Kind_db.t
   }
 
 and resolve_result =
@@ -1037,7 +1042,12 @@ end = struct
 
   let instantiate db name info ~hidden = Memo.exec memo (db, name, info, hidden)
 
-  let find_internal db (name : Lib_name.t) = resolve_name db name
+  let find_internal db (name : Lib_name.t) =
+    let () =
+      match db.kind with
+      | Kind_db.Installed_libs -> Lib_resolved.External_libs.add db.lib_config.context_name name
+      | _ -> ()
+    in resolve_name db name
 
   let resolve_dep db (loc, name) ~private_deps : t Resolve.Memo.t =
     let open Memo.O in
@@ -1177,6 +1187,9 @@ end = struct
       { resolved; selects; re_exports }
   end
 
+  let set_external_libs_kind db name kind =
+    Lib_resolved.External_libs.set db.lib_config.context_name name kind
+
   let remove_library deps target =
     List.filter_map deps ~f:(fun (dep : Lib_dep.t) ->
         match dep with
@@ -1211,6 +1224,10 @@ end = struct
                      Lib_name.Set.fold required ~init:[] ~f:(fun x acc ->
                          (loc, x) :: acc)
                    in
+                   let () = List.iter
+                              ~f:(fun lib ->
+                                set_external_libs_kind db (snd lib) Lib_resolved.Kind.Optional) deps
+                   in
                    resolve_simple_deps ~private_deps db deps)
                 >>| function
                 | Ok ts -> Some (ts, file)
@@ -1242,9 +1259,11 @@ end = struct
       Memo.List.fold_left deps ~init:empty ~f:(fun acc dep ->
           match (dep : Lib_dep.t) with
           | Re_export lib ->
+            let () = set_external_libs_kind db (snd lib) Lib_resolved.Kind.Required in
             let+ lib = resolve_dep db lib ~private_deps in
             add_re_exports acc lib
           | Direct lib ->
+            let () = set_external_libs_kind db (snd lib) Lib_resolved.Kind.Required in
             let+ lib = resolve_dep db lib ~private_deps in
             add_resolved acc lib
           | Select select ->
@@ -1691,12 +1710,13 @@ module DB = struct
 
   type t = db
 
-  let create ~parent ~resolve ~all ~lib_config () =
+  let create ~parent ~resolve ~all ~lib_config ~kind () =
     { parent
     ; resolve
     ; all = Memo.lazy_ all
     ; lib_config
     ; instrument_with = lib_config.Lib_config.instrument_with
+    ; kind
     }
 
   let create_from_findlib findlib =
@@ -1716,6 +1736,7 @@ module DB = struct
       ~all:(fun () ->
         let open Memo.O in
         Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.name)
+      ~kind:Kind_db.Installed_libs
 
   let installed (context : Context.t) =
     let open Memo.O in

src/dune_rules/lib.mli

@@ -41,6 +41,10 @@ val hash : t -> int
 
 val project : t -> Dune_project.t option
 
+module Kind_db : sig
+  type t = Installed_libs | Public_libs | Project_libs
+end
+
 (** Operations on list of libraries *)
 module L : sig
   val top_closure :
@@ -124,6 +128,7 @@ module DB : sig
     -> resolve:(Lib_name.t -> Resolve_result.t Memo.t)
     -> all:(unit -> Lib_name.t list Memo.t)
     -> lib_config:Lib_config.t
+    -> kind: Kind_db.t
     -> unit
     -> t
 

src/dune_rules/lib_resolved.ml

@@ -0,0 +1,82 @@
+open Import
+
+module Kind = struct
+
+  type t =
+    | Required
+    | Optional
+
+  let to_dyn kind =
+    match kind with
+    | Required -> Dyn.String "require"
+    | Optional -> Dyn.String "optional"
+
+  let merge x y =
+    match (x,y) with
+    | Optional,Optional -> Optional
+    | _ -> Required
+
+  let merge_opt x y=
+    match (x,y) with
+    | Some x,Some y -> Some (merge x y)
+    | None, y -> y
+    | x, None -> x
+
+end
+
+module External_libs = struct
+
+  module Hashtbl = Hashtbl.Make(Context_name)
+  module Map = Lib_name.Map
+
+  let libs_by_ctx = Hashtbl.create 1
+
+  let add ctx lib =
+    match Hashtbl.find libs_by_ctx ctx with
+    | Some libs ->
+      if not(Map.mem libs lib)
+      then ignore(Hashtbl.set libs_by_ctx ctx (Lib_name.Map.add_exn libs lib None))
+    | None ->
+      ignore(Hashtbl.add libs_by_ctx ctx (Lib_name.Map.add_exn Lib_name.Map.empty lib None))
+
+  let set ctx lib kind =
+    let f v =
+      match v with
+      | Some k -> Some (Kind.merge_opt k (Some (kind)))
+      | None   -> None
+    in
+    match Hashtbl.find libs_by_ctx ctx with
+    | Some libs -> ignore(Hashtbl.set libs_by_ctx ctx (Lib_name.Map.update libs lib ~f:f))
+    | None      -> ()
+
+  let filter_libs libs = Lib_name.Map.filter_map libs ~f:(fun kind ->
+    match kind with
+    | Some k -> Some k
+    | None   -> None)
+
+  let print () =
+    let pp libs =
+      let libs =
+        List.sort (Lib_name.Map.to_list (filter_libs libs)) ~compare:(fun (x,_) (y,_) -> Lib_name.compare x y)
+      in
+      Pp.enumerate libs ~f:(fun (lib,kind) ->
+        match kind with
+        | Kind.Required -> Pp.textf "%s" (Lib_name.to_string lib)
+        | Kind.Optional -> Pp.textf "%s (optional)" (Lib_name.to_string lib))
+    in
+    (User_message.make
+       (Hashtbl.foldi libs_by_ctx ~init:[] ~f:(fun ctx libs acc ->
+          [ Pp.textf
+              "These are the external library dependencies in the %s context"
+              (Context_name.to_string ctx);
+            pp libs ] @ acc)))
+
+  let sexp () =
+    let dyn libs = Lib_name.Map.to_dyn (fun kind -> Kind.to_dyn kind) libs in
+    (User_message.make
+       (Hashtbl.foldi libs_by_ctx ~init:[] ~f:(fun ctx libs acc ->
+          [(Sexp.pp
+              (List
+                 [ Atom (Context_name.to_string ctx); Sexp.of_dyn (dyn (filter_libs libs))] ));
+          ] @ acc)))
+end

src/dune_rules/lib_resolved.mli

@@ -0,0 +1,14 @@
+open Import
+
+module Kind :sig
+  type t =
+    | Required
+    | Optional
+end
+
+module External_libs : sig
+  val add : Context_name.t -> Lib_name.t -> unit
+  val set : Context_name.t -> Lib_name.t -> Kind.t -> unit
+  val print : unit -> Stdune.User_message.t
+  val sexp  : unit -> Stdune.User_message.t
+end

src/dune_rules/scope.ml

@@ -128,6 +128,7 @@ module DB = struct
           | Some (Found lib) -> Lib.DB.Resolve_result.found lib))
       ~all:(fun () -> Lib_name.Map.keys map |> Memo.return)
       ~lib_config
+      ~kind:Lib.Kind_db.Project_libs
 
   type redirect_to =
     | Project of Dune_project.t
@@ -187,7 +188,7 @@ module DB = struct
     let resolve lib = Memo.return (resolve t public_libs lib) in
     Lib.DB.create ~parent:(Some installed_libs) ~resolve
       ~all:(fun () -> Lib_name.Map.keys public_libs |> Memo.return)
-      ~lib_config ()
+      ~lib_config ~kind:Lib.Kind_db.Public_libs ()
 
   module Path_source_map_traversals = Memo.Make_map_traversals (Path.Source.Map)