diff --git a/src/bin.ml b/src/bin.ml index 8c79047d..5b718711 100644 --- a/src/bin.ml +++ b/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 diff --git a/src/bin.mli b/src/bin.mli index 61d3f7f9..edaf690b 100644 --- a/src/bin.mli +++ b/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 diff --git a/src/findlib.ml b/src/findlib.ml index 4a9cde7a..c466b812 100644 --- a/src/findlib.ml +++ b/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 diff --git a/src/future.ml b/src/future.ml index 40fbaa93..85af3d51 100644 --- a/src/future.ml +++ b/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 diff --git a/src/import.ml b/src/import.ml index f5b19da8..3de3faee 100644 --- a/src/import.ml +++ b/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 diff --git a/src/loc.ml b/src/loc.ml index e7bf4525..2c480511 100644 --- a/src/loc.ml +++ b/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