handle findlib properly

src/bin.ml

@@ -48,6 +48,11 @@ let find_prog prog =
   in
   search path
 
+let locate prog =
+  match find_prog prog with
+  | None -> None
+  | Some (_, fn) -> Some fn
+
 let prog_not_found_in_path prog =
   Printf.eprintf "Program %s not found in PATH" prog;
   exit 2

src/bin.mli

@@ -8,3 +8,5 @@ val ocamlc : string
 val ocamlopt : string option
 val ocamldep : string
 val ocamllex : string
+
+val locate : string -> string option

src/findlib.ml

@@ -79,7 +79,16 @@ let acknowledge_meta (meta : Meta.t) =
       in
       Hashtbl.add db name { name; vars })
 
-let findlib_dir = Filename.dirname Bin.dir ^/ "lib"
+let findlib_dirs =
+  match Bin.locate "ocamlfind" with
+  | Some fn ->
+    ksprintf run_and_read_lines "%s printconf path" fn
+  | None ->
+    match Bin.locate "opam" with
+    | None ->
+      [Filename.dirname Bin.dir ^/ "lib"]
+    | Some fn ->
+      [run_and_read_line "%s config var root"]
 
 exception Package_not_found of string
 
@@ -88,24 +97,38 @@ let root_pkg s =
   | exception Not_found -> s
   | i -> String.sub s ~pos:0 ~len:i
 
+let load_meta root_name =
+  let rec loop dirs =
+    match dirs with
+    | [] -> raise (Package_not_found root_name)
+    | dir :: dirs ->
+      let fn = dir ^/ root_name ^/ "META" in
+      if Sys.file_exists fn then
+        acknowledge_meta
+          { name    = root_name
+          ; entries = Meta.load fn
+          }
+      else
+        loop dirs
+  in
+  loop findlib_dirs
+
 let rec get_pkg name =
   match Hashtbl.find db name with
   | exception Not_found ->
-    let root = root_pkg name in
-    let fn = findlib_dir ^/ root ^/ "META" in
-    if Sys.file_exists fn then begin
-      acknowledge_meta { name = root; entries = Meta.load fn };
-      get_pkg name
-    end else
-      raise (Package_not_found name)
+    load_meta (root_pkg name);
+    get_pkg name
   | pkg -> pkg
 
 let root_packages =
   let v = lazy (
-    Sys.readdir findlib_dir
-    |> Array.to_list
-    |> List.filter ~f:(fun name ->
-        Sys.file_exists (findlib_dir ^/ name ^/ "META"))
+    List.map findlib_dirs ~f:(fun dir ->
+        Sys.readdir dir
+        |> Array.to_list
+        |> List.filter ~f:(fun name ->
+            Sys.file_exists (dir ^/ name ^/ "META")))
+    |> List.concat
+    |> List.sort ~cmp:String.compare
   ) in
   fun () -> Lazy.force v
 

src/future.ml

@@ -120,15 +120,8 @@ module Scheduler = struct
     | Some fn -> sprintf "%s > %s" s fn
 
   let process_done job status =
-    match status with
-    | Unix.WEXITED 0 -> Ivar.fill job.ivar ()
-    | _ ->
-      Printf.ksprintf failwith "Process \"%s\" exited with status %d"
-        (command_line job)
-        (match status with
-         | WEXITED n -> n
-         | WSIGNALED n -> 128 + n
-         | WSTOPPED _ -> assert false)
+    handle_process_status (lazy (command_line job)) status;
+    Ivar.fill job.ivar ()
 
   let running = Hashtbl.create 128
 

src/import.ml

@@ -42,6 +42,7 @@ type ('a, 'b) eq =
 let (^/) a b = a ^ "/" ^ b
 
 let sprintf = Printf.sprintf
+let ksprintf = Printf.ksprintf
 
 let protectx x ~finally ~f =
   match f x with
@@ -62,10 +63,40 @@ let with_lexbuf_from_file fn ~f =
         };
       f lb)
 
-let lines_of_file fn =
+let input_lines =
   let rec loop ic acc =
     match input_line ic with
     | exception End_of_file -> List.rev acc
     | line -> loop ic (line :: acc)
   in
-  with_file_in fn ~f:(fun ic -> loop ic [])
+  fun ic -> loop ic []
+
+let lines_of_file fn = with_file_in fn ~f:input_lines
+
+exception Error of string
+let die fmt = ksprintf (fun msg -> raise (Error msg)) fmt
+
+let handle_process_status cmd (status : Unix.process_status) =
+  match status with
+  | WEXITED   0 -> ()
+  | WEXITED   n -> die "Command exited with code %d: %s"     n (Lazy.force cmd)
+  | WSIGNALED n -> die "Command got killed by signal %d: %s" n (Lazy.force cmd)
+  | WSTOPPED  _ -> assert false
+
+let with_process_in cmd ~f =
+  let ic = Unix.open_process_in cmd in
+  match f ic with
+  | exception e ->
+    ignore (Unix.close_process_in ic : Unix.process_status);
+    raise e
+  | y ->
+    handle_process_status (lazy cmd) (Unix.close_process_in ic);
+    y
+
+let run_and_read_lines cmd = with_process_in cmd ~f:input_lines
+
+let run_and_read_line cmd =
+  match run_and_read_lines cmd with
+  | []  -> die "Command returned no output: %s" cmd
+  | [x] -> x
+  | _   -> die "Command returned too many lines: %s" cmd

src/loc.ml

@@ -1,3 +1,5 @@
+open Import
+
 type t =
   { start : Lexing.position
   ; stop  : Lexing.position
@@ -11,7 +13,7 @@ let of_lexbuf lb =
 exception Error of t * string
 
 let fail t fmt =
-  Printf.ksprintf (fun msg -> raise (Error (t, msg))) fmt
+  ksprintf (fun msg -> raise (Error (t, msg))) fmt
 
 let fail_lex lb fmt =
   fail (of_lexbuf lb) fmt