Avoid loading findlib packages more than once

CHANGES.org

@@ -16,6 +16,7 @@
   + =runtest=
   + =install=
   + =uninstall=
+  + =installed-libraries=
 
 - Added support for aliases
   (#7, Rudi Grinberg)

bin/main.ml

@@ -12,36 +12,6 @@ let (>>=) = Future.(>>=)
 
 let create_log = Main.create_log
 
-(* TODO: rewrite this when command trees are supported.
-
-   https://github.com/dbuenzli/cmdliner/issues/24 *)
-let internal = function
-  | [_; "findlib-packages"] ->
-    Future.Scheduler.go ~log:(create_log ())
-      (Lazy.force Context.default >>= fun ctx ->
-       let findlib = Findlib.create ctx in
-       let pkgs = Findlib.all_packages findlib in
-       let max_len =
-         List.map pkgs ~f:String.length
-         |> List.fold_left ~init:0 ~f:max
-       in
-       List.iter pkgs ~f:(fun pkg ->
-         let ver =
-           match (Findlib.find_exn findlib pkg).version with
-           | "" -> "n/a"
-           | v  -> v
-         in
-         Printf.printf "%-*s (version: %s)\n" max_len pkg ver);
-       Future.return ())
-  | _ ->
-    ()
-
-let internal =
-  let doc = "internal use only" in
-  let name_ = Arg.info [] in
-  ( Term.(const internal $ Arg.(non_empty & pos_all string [] name_))
-  , Term.info "internal" ~doc)
-
 type common =
   { concurrency: int
   ; debug_rules: bool
@@ -85,6 +55,29 @@ let common =
   let dev = Arg.(value & flag & info ["dev"] ~docs) in
   Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib $ dev)
 
+let installed_libraries =
+  let doc = "Print out libraries installed on the system." in
+  let go common =
+    set_common common;
+    Future.Scheduler.go ~log:(create_log ())
+      (Lazy.force Context.default >>= fun ctx ->
+       let findlib = Findlib.create ctx in
+       let pkgs = Findlib.all_packages findlib in
+       let max_len = List.longest_map pkgs ~f:(fun p -> p.name) in
+       List.iter pkgs ~f:(fun pkg ->
+         let ver =
+           match pkg.Findlib.version with
+           | "" -> "n/a"
+           | v  -> v
+         in
+         Printf.printf "%-*s (version: %s)\n" max_len pkg.name ver);
+       Future.return ())
+  in
+  ( Term.(const go
+          $ common)
+  , Term.info "installed-libraries" ~doc
+  )
+
 let resolve_package_install setup pkg =
   match Main.package_install_file setup pkg with
   | Ok path -> path
@@ -98,7 +91,7 @@ let build_package pkg =
        [resolve_package_install setup pkg])
 
 let build_package =
-  let doc = "build a package in release mode" in
+  let doc = "Build a single package in release mode." in
   let name_ = Arg.info [] ~docv:"PACKAGE-NAME" in
   let go common pkg =
     set_common common;
@@ -121,7 +114,7 @@ let external_lib_deps packages =
     | Optional -> Printf.printf "%s (optional)\n" n)
 
 let external_lib_deps =
-  let doc = "print out external library dependencies" in
+  let doc = "Print out external library dependencies." in
   let name_ = Arg.info [] ~docv:"PACKAGE-NAME" in
   let go common packages =
     set_common common;
@@ -188,7 +181,7 @@ let resolve_targets (setup : Main.setup) user_targets =
       | Alias (_, alias) -> Alias.file alias)
 
 let build_targets =
-  let doc = "build targets" in
+  let doc = "Build targets." in
   let name_ = Arg.info [] ~docv:"TARGET" in
   let go common targets =
     set_common common;
@@ -202,7 +195,7 @@ let build_targets =
   , Term.info "build" ~doc ~man:help_secs)
 
 let runtest =
-  let doc = "run tests" in
+  let doc = "Run tests." in
   let name_ = Arg.info [] ~docv:"DIR" in
   let go common dirs =
     set_common common;
@@ -241,7 +234,7 @@ let get_prefix (setup : Main.setup) ~from_command_line =
   | None -> Context.install_prefix setup.context
 
 let install_uninstall ~what =
-  let doc = sprintf "%s packages" what in
+  let doc = sprintf "%s packages using opam-installer." (String.capitalize what) in
   let name_ = Arg.info [] ~docv:"PACKAGE" in
   let go common prefix pkgs =
     set_common common;
@@ -284,7 +277,7 @@ let install   = install_uninstall ~what:"install"
 let uninstall = install_uninstall ~what:"uninstall"
 
 let all =
-  [ internal
+  [ installed_libraries
   ; build_package
   ; external_lib_deps
   ; build_targets

src/findlib.ml

@@ -144,7 +144,12 @@ let has_headers t ~dir =
   match Hashtbl.find t.has_headers dir with
   | Some x -> x
   | None ->
-    let x = List.exists (Path.readdir dir) ~f:(fun fn -> Filename.check_suffix fn ".h") in
+    let x =
+      match Path.readdir dir with
+      | exception _ -> false
+      | files ->
+        List.exists files ~f:(fun fn -> Filename.check_suffix fn ".h")
+    in
     Hashtbl.add t.has_headers ~key:dir ~data:x;
     x
 
@@ -227,7 +232,8 @@ let root_package_name s =
   | Some i -> String.sub s ~pos:0 ~len:i
 
 let rec load_meta_rec t root_name ~packages =
-  if String_map.mem root_name packages then
+  if String_map.mem root_name packages ||
+     Hashtbl.mem t.packages root_name then
     packages
   else
     let rec loop dirs : Path.t * Meta.t =
@@ -419,8 +425,8 @@ let root_packages t =
 let all_packages t =
   List.iter (root_packages t) ~f:(fun pkg ->
     ignore (find_exn t pkg : package));
-  Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:pkg ~data acc ->
+  Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:_ ~data acc ->
     match data with
-    | Present _ -> pkg :: acc
+    | Present p -> p :: acc
     | Absent    -> acc)
-  |> List.sort ~cmp:String.compare
+  |> List.sort ~cmp:(fun a b -> String.compare a.name b.name)

src/findlib.mli

@@ -9,9 +9,6 @@ val create : Context.t -> t
 
 val context : t -> Context.t
 
-val root_packages : t -> string list
-val all_packages  : t -> string list
-
 type package =
   { name             : string
   ; dir              : Path.t
@@ -32,3 +29,6 @@ val root_package_name : string -> string
 
 val closure : package list -> package list
 val closed_ppx_runtime_deps_of : package list -> package list
+
+val root_packages : t -> string list
+val all_packages  : t -> package list