Allow 'ocamlfind printconf path' to fail
This commit is contained in:
parent
4dca707479
commit
bd9033f9bb
|
@ -279,7 +279,7 @@ let install_uninstall ~what =
|
||||||
get_prefix context ~from_command_line:prefix >>= fun prefix ->
|
get_prefix context ~from_command_line:prefix >>= fun prefix ->
|
||||||
Future.all_unit
|
Future.all_unit
|
||||||
(List.map install_files ~f:(fun path ->
|
(List.map install_files ~f:(fun path ->
|
||||||
Future.run (Path.to_string opam_installer)
|
Future.run Strict (Path.to_string opam_installer)
|
||||||
[ sprintf "-%c" what.[0]
|
[ sprintf "-%c" what.[0]
|
||||||
; "--prefix"
|
; "--prefix"
|
||||||
; Path.to_string prefix
|
; Path.to_string prefix
|
||||||
|
|
|
@ -7,8 +7,11 @@ module List = ListLabels
|
||||||
module String = struct
|
module String = struct
|
||||||
include StringLabels
|
include StringLabels
|
||||||
|
|
||||||
let capitalize_ascii = String.capitalize_ascii
|
include struct
|
||||||
let uncapitalize_ascii = String.uncapitalize_ascii
|
[@@@warning "-3"]
|
||||||
|
let capitalize_ascii = String.capitalize
|
||||||
|
let uncapitalize_ascii = String.uncapitalize
|
||||||
|
end
|
||||||
end
|
end
|
||||||
|
|
||||||
open Printf
|
open Printf
|
||||||
|
@ -269,7 +272,7 @@ end
|
||||||
output_string oc s;
|
output_string oc s;
|
||||||
pos_in_generated_file := !pos_in_generated_file + count_newlines s;
|
pos_in_generated_file := !pos_in_generated_file + count_newlines s;
|
||||||
List.iter modules ~f:(fun m ->
|
List.iter modules ~f:(fun m ->
|
||||||
let base = String.uncapitalize m in
|
let base = String.uncapitalize_ascii m in
|
||||||
let mli = sprintf "src/%s.mli" base in
|
let mli = sprintf "src/%s.mli" base in
|
||||||
let ml = sprintf "src/%s.ml" base in
|
let ml = sprintf "src/%s.ml" base in
|
||||||
if Sys.file_exists mli then begin
|
if Sys.file_exists mli then begin
|
||||||
|
|
|
@ -157,7 +157,7 @@ let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args =
|
||||||
prim ~targets
|
prim ~targets
|
||||||
(fun (prog, args) ->
|
(fun (prog, args) ->
|
||||||
let stdout_to = Option.map stdout_to ~f:Path.to_string in
|
let stdout_to = Option.map stdout_to ~f:Path.to_string in
|
||||||
Future.run ~dir:(Path.to_string dir) ?stdout_to ?env
|
Future.run Strict ~dir:(Path.to_string dir) ?stdout_to ?env
|
||||||
(Path.reach prog ~from:dir) args)
|
(Path.reach prog ~from:dir) args)
|
||||||
|
|
||||||
let run_capture_gen ~f ?(dir=Path.root) ?env prog args =
|
let run_capture_gen ~f ?(dir=Path.root) ?env prog args =
|
||||||
|
@ -166,7 +166,8 @@ let run_capture_gen ~f ?(dir=Path.root) ?env prog args =
|
||||||
>>>
|
>>>
|
||||||
prim ~targets
|
prim ~targets
|
||||||
(fun (prog, args) ->
|
(fun (prog, args) ->
|
||||||
f ?dir:(Some (Path.to_string dir)) ?env (Path.reach prog ~from:dir) args)
|
f ?dir:(Some (Path.to_string dir)) ?env
|
||||||
|
Future.Strict (Path.reach prog ~from:dir) args)
|
||||||
|
|
||||||
let run_capture ?dir ?env prog args =
|
let run_capture ?dir ?env prog args =
|
||||||
run_capture_gen ~f:Future.run_capture ?dir ?env prog args
|
run_capture_gen ~f:Future.run_capture ?dir ?env prog args
|
||||||
|
@ -181,8 +182,8 @@ let action ~targets =
|
||||||
List.iter touches ~f:(fun fn ->
|
List.iter touches ~f:(fun fn ->
|
||||||
close_out (open_out_bin (Path.to_string fn)));
|
close_out (open_out_bin (Path.to_string fn)));
|
||||||
let stdout_to = Option.map stdout_to ~f:Path.to_string in
|
let stdout_to = Option.map stdout_to ~f:Path.to_string in
|
||||||
Future.run ~dir:(Path.to_string dir) ~env ?stdout_to (Path.reach ~from:dir prog)
|
Future.run Strict ~dir:(Path.to_string dir) ~env ?stdout_to
|
||||||
args)
|
(Path.reach ~from:dir prog) args)
|
||||||
|
|
||||||
let echo fn =
|
let echo fn =
|
||||||
create_file ~target:fn (fun data ->
|
create_file ~target:fn (fun data ->
|
||||||
|
|
|
@ -80,7 +80,7 @@ let opam_config_var ~env ~cache var =
|
||||||
match Bin.opam with
|
match Bin.opam with
|
||||||
| None -> return None
|
| None -> return None
|
||||||
| Some fn ->
|
| Some fn ->
|
||||||
Future.run_capture (Path.to_string fn) ~env ["config"; "var"; var]
|
Future.run_capture Strict (Path.to_string fn) ~env ["config"; "var"; var]
|
||||||
>>| fun s ->
|
>>| fun s ->
|
||||||
let s = String.trim s in
|
let s = String.trim s in
|
||||||
Hashtbl.add cache ~key:var ~data:s;
|
Hashtbl.add cache ~key:var ~data:s;
|
||||||
|
@ -126,8 +126,11 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin =
|
||||||
| None ->
|
| None ->
|
||||||
return []
|
return []
|
||||||
| Some fn ->
|
| Some fn ->
|
||||||
Future.run_capture_lines ~env (Path.to_string fn) ["printconf"; "path"]
|
Future.run_capture_lines ~env (Accept [127])
|
||||||
>>| List.map ~f:Path.absolute)
|
(Path.to_string fn) ["printconf"; "path"]
|
||||||
|
>>| function
|
||||||
|
| Ok lines -> List.map lines ~f:Path.absolute
|
||||||
|
| Error _ -> [])
|
||||||
>>| fun (a, b) ->
|
>>| fun (a, b) ->
|
||||||
match a @ b with
|
match a @ b with
|
||||||
| [] -> [Path.relative (Path.parent dir) "lib"]
|
| [] -> [Path.relative (Path.parent dir) "lib"]
|
||||||
|
@ -138,7 +141,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin =
|
||||||
else
|
else
|
||||||
x :: acc)
|
x :: acc)
|
||||||
|> List.rev)
|
|> List.rev)
|
||||||
(Future.run_capture_lines ~env (Path.to_string ocamlc) ["-config"])
|
(Future.run_capture_lines ~env Strict (Path.to_string ocamlc) ["-config"])
|
||||||
>>= fun (findlib_path, ocamlc_config) ->
|
>>= fun (findlib_path, ocamlc_config) ->
|
||||||
let ocamlc_config =
|
let ocamlc_config =
|
||||||
List.map ocamlc_config ~f:(fun line ->
|
List.map ocamlc_config ~f:(fun line ->
|
||||||
|
@ -272,9 +275,9 @@ let create_for_opam ?root ~switch ~name ?(merlin=false) () =
|
||||||
(match root with
|
(match root with
|
||||||
| Some root -> return root
|
| Some root -> return root
|
||||||
| None ->
|
| None ->
|
||||||
Future.run_capture_line (Path.to_string fn) ["config"; "var"; "root"])
|
Future.run_capture_line Strict (Path.to_string fn) ["config"; "var"; "root"])
|
||||||
>>= fun root ->
|
>>= fun root ->
|
||||||
Future.run_capture (Path.to_string fn)
|
Future.run_capture Strict (Path.to_string fn)
|
||||||
["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"]
|
["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"]
|
||||||
>>= fun s ->
|
>>= fun s ->
|
||||||
let vars =
|
let vars =
|
||||||
|
|
121
src/future.ml
121
src/future.ml
|
@ -134,62 +134,103 @@ let rec all_unit = function
|
||||||
x >>= fun () ->
|
x >>= fun () ->
|
||||||
all_unit l
|
all_unit l
|
||||||
|
|
||||||
|
type ('a, 'b) failure_mode =
|
||||||
|
| Strict : ('a, 'a) failure_mode
|
||||||
|
| Accept : int list -> ('a, ('a, int) result) failure_mode
|
||||||
|
|
||||||
|
let accepted_codes : type a b. (a, b) failure_mode -> int list = function
|
||||||
|
| Strict -> [0]
|
||||||
|
| Accept codes -> 0 :: codes
|
||||||
|
|
||||||
|
let map_result
|
||||||
|
: type a b. (a, b) failure_mode -> int t -> f:(unit -> a) -> b t
|
||||||
|
= fun mode future ~f ->
|
||||||
|
match mode with
|
||||||
|
| Strict -> future >>| fun _ -> f ()
|
||||||
|
| Accept _ ->
|
||||||
|
future >>| function
|
||||||
|
| 0 -> Ok (f ())
|
||||||
|
| n -> Error n
|
||||||
|
|
||||||
type job =
|
type job =
|
||||||
{ prog : string
|
{ prog : string
|
||||||
; args : string list
|
; args : string list
|
||||||
; dir : string option
|
; dir : string option
|
||||||
; stdout_to : string option
|
; stdout_to : string option
|
||||||
; env : string array option
|
; env : string array option
|
||||||
; ivar : unit Ivar.t
|
; ivar : int Ivar.t
|
||||||
|
; ok_codes : int list
|
||||||
}
|
}
|
||||||
|
|
||||||
let to_run : job Queue.t = Queue.create ()
|
let to_run : job Queue.t = Queue.create ()
|
||||||
|
|
||||||
let run ?dir ?stdout_to ?env prog args =
|
let run_internal ?dir ?stdout_to ?env fail_mode prog args =
|
||||||
let dir =
|
let dir =
|
||||||
match dir with
|
match dir with
|
||||||
| Some "." -> None
|
| Some "." -> None
|
||||||
| _ -> dir
|
| _ -> dir
|
||||||
in
|
in
|
||||||
create (fun ivar ->
|
create (fun ivar ->
|
||||||
Queue.push { prog; args; dir; stdout_to; env; ivar } to_run)
|
Queue.push { prog
|
||||||
|
; args
|
||||||
|
; dir
|
||||||
|
; stdout_to
|
||||||
|
; env
|
||||||
|
; ivar
|
||||||
|
; ok_codes = accepted_codes fail_mode
|
||||||
|
} to_run)
|
||||||
|
|
||||||
let tmp_files = ref String_set.empty
|
let run ?dir ?stdout_to ?env fail_mode prog args =
|
||||||
let () =
|
map_result fail_mode (run_internal ?dir ?stdout_to ?env fail_mode prog args)
|
||||||
at_exit (fun () ->
|
~f:ignore
|
||||||
let fns = !tmp_files in
|
|
||||||
tmp_files := String_set.empty;
|
|
||||||
String_set.iter fns ~f:(fun fn ->
|
|
||||||
try Sys.remove fn with _ -> ()))
|
|
||||||
|
|
||||||
let run_capture_gen ?dir ?env prog args ~f =
|
module Temp = struct
|
||||||
let fn = Filename.temp_file "jbuild" ".output" in
|
let tmp_files = ref String_set.empty
|
||||||
tmp_files := String_set.add fn !tmp_files;
|
let () =
|
||||||
run ?dir ~stdout_to:fn ?env prog args >>= fun () ->
|
at_exit (fun () ->
|
||||||
let s = f fn in
|
let fns = !tmp_files in
|
||||||
Sys.remove fn;
|
tmp_files := String_set.empty;
|
||||||
tmp_files := String_set.remove fn !tmp_files;
|
String_set.iter fns ~f:(fun fn ->
|
||||||
return s
|
try Sys.remove fn with _ -> ()))
|
||||||
|
|
||||||
|
let create prefix suffix =
|
||||||
|
let fn = Filename.temp_file prefix suffix in
|
||||||
|
tmp_files := String_set.add fn !tmp_files;
|
||||||
|
fn
|
||||||
|
|
||||||
|
let destroy fn =
|
||||||
|
Sys.remove fn;
|
||||||
|
tmp_files := String_set.remove fn !tmp_files
|
||||||
|
end
|
||||||
|
|
||||||
|
let run_capture_gen ?dir ?env fail_mode prog args ~f =
|
||||||
|
let fn = Temp.create "jbuild" ".output" in
|
||||||
|
map_result fail_mode (run_internal ?dir ~stdout_to:fn ?env fail_mode prog args)
|
||||||
|
~f:(fun () ->
|
||||||
|
let x = f fn in
|
||||||
|
Temp.destroy fn;
|
||||||
|
x)
|
||||||
|
|
||||||
let run_capture = run_capture_gen ~f:read_file
|
let run_capture = run_capture_gen ~f:read_file
|
||||||
let run_capture_lines = run_capture_gen ~f:lines_of_file
|
let run_capture_lines = run_capture_gen ~f:lines_of_file
|
||||||
|
|
||||||
let run_capture_line ?dir ?env prog args =
|
let run_capture_line ?dir ?env fail_mode prog args =
|
||||||
run_capture_lines ?dir ?env prog args >>| function
|
run_capture_gen ?dir ?env fail_mode prog args ~f:(fun fn ->
|
||||||
| [x] -> x
|
match lines_of_file fn with
|
||||||
| l ->
|
| [x] -> x
|
||||||
let cmdline =
|
| l ->
|
||||||
let s = String.concat (prog :: args) ~sep:" " in
|
let cmdline =
|
||||||
match dir with
|
let s = String.concat (prog :: args) ~sep:" " in
|
||||||
| None -> s
|
match dir with
|
||||||
| Some dir -> sprintf "cd %s && %s" dir s
|
| None -> s
|
||||||
in
|
| Some dir -> sprintf "cd %s && %s" dir s
|
||||||
match l with
|
in
|
||||||
| [] ->
|
match l with
|
||||||
die "command returned nothing: %s" cmdline
|
| [] ->
|
||||||
| _ ->
|
die "command returned nothing: %s" cmdline
|
||||||
die "command returned too many lines: %s\n%s"
|
| _ ->
|
||||||
cmdline (String.concat l ~sep:"\n")
|
die "command returned too many lines: %s\n%s"
|
||||||
|
cmdline (String.concat l ~sep:"\n"))
|
||||||
|
|
||||||
module Scheduler = struct
|
module Scheduler = struct
|
||||||
let colorize_prog s =
|
let colorize_prog s =
|
||||||
|
@ -302,7 +343,7 @@ module Scheduler = struct
|
||||||
else
|
else
|
||||||
s
|
s
|
||||||
in
|
in
|
||||||
Sys.remove job.output_filename;
|
Temp.destroy job.output_filename;
|
||||||
Option.iter job.log ~f:(fun oc ->
|
Option.iter job.log ~f:(fun oc ->
|
||||||
Printf.fprintf oc "$ %s\n%s"
|
Printf.fprintf oc "$ %s\n%s"
|
||||||
(Ansi_color.strip job.command_line)
|
(Ansi_color.strip job.command_line)
|
||||||
|
@ -316,10 +357,14 @@ module Scheduler = struct
|
||||||
);
|
);
|
||||||
if not exiting then begin
|
if not exiting then begin
|
||||||
match status with
|
match status with
|
||||||
| WEXITED 0 ->
|
| WEXITED n when List.mem n ~set:job.job.ok_codes ->
|
||||||
if output <> "" then
|
if output <> "" then
|
||||||
Format.eprintf "@{<kwd>Output@}[@{<id>%d@}]:\n%s%!" job.id output;
|
Format.eprintf "@{<kwd>Output@}[@{<id>%d@}]:\n%s%!" job.id output;
|
||||||
Ivar.fill job.job.ivar ()
|
if n <> 0 then
|
||||||
|
Format.eprintf
|
||||||
|
"@{<warning>Warning@}: Command [@{<id>%d@}] exited with code %d, \
|
||||||
|
but I'm ignore it, hope that's OK.\n%!" job.id n;
|
||||||
|
Ivar.fill job.job.ivar n
|
||||||
| WEXITED n ->
|
| WEXITED n ->
|
||||||
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] exited with code %d:\n\
|
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] exited with code %d:\n\
|
||||||
@{<prompt>$@} %s\n%s%!"
|
@{<prompt>$@} %s\n%s%!"
|
||||||
|
@ -380,7 +425,7 @@ module Scheduler = struct
|
||||||
Format.eprintf "@{<kwd>Running@}[@{<id>%d@}]: %s@." id
|
Format.eprintf "@{<kwd>Running@}[@{<id>%d@}]: %s@." id
|
||||||
(Ansi_color.strip_colors_for_stderr command_line);
|
(Ansi_color.strip_colors_for_stderr command_line);
|
||||||
let argv = Array.of_list (job.prog :: job.args) in
|
let argv = Array.of_list (job.prog :: job.args) in
|
||||||
let output_filename = Filename.temp_file "jbuilder" ".output" in
|
let output_filename = Temp.create "jbuilder" ".output" in
|
||||||
let output_fd = Unix.openfile output_filename [O_WRONLY] 0 in
|
let output_fd = Unix.openfile output_filename [O_WRONLY] 0 in
|
||||||
let stdout, close_stdout =
|
let stdout, close_stdout =
|
||||||
match job.stdout_to with
|
match job.stdout_to with
|
||||||
|
|
|
@ -1,5 +1,7 @@
|
||||||
(** Simplified Async/Lwt like monad *)
|
(** Simplified Async/Lwt like monad *)
|
||||||
|
|
||||||
|
open Import
|
||||||
|
|
||||||
type 'a t
|
type 'a t
|
||||||
|
|
||||||
val return : 'a -> 'a t
|
val return : 'a -> 'a t
|
||||||
|
@ -13,34 +15,46 @@ val all_unit : unit t list -> unit t
|
||||||
|
|
||||||
val with_exn_handler : (unit -> 'a) -> handler:(exn -> Printexc.raw_backtrace -> unit) -> 'a
|
val with_exn_handler : (unit -> 'a) -> handler:(exn -> Printexc.raw_backtrace -> unit) -> 'a
|
||||||
|
|
||||||
|
(** How to handle sub-process failures *)
|
||||||
|
type ('a, 'b) failure_mode =
|
||||||
|
| Strict : ('a, 'a) failure_mode
|
||||||
|
(** Fail if the process exits with anything else than [0] *)
|
||||||
|
| Accept : int list -> ('a, ('a, int) result) failure_mode
|
||||||
|
(** Accept the following non-zero exit codes, and return [Error code] if the process
|
||||||
|
exists with one of these codes. *)
|
||||||
|
|
||||||
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
|
(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *)
|
||||||
val run
|
val run
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?stdout_to:string
|
-> ?stdout_to:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> (unit, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
-> unit t
|
-> 'a t
|
||||||
|
|
||||||
(** Run a command and capture its output *)
|
(** Run a command and capture its output *)
|
||||||
val run_capture
|
val run_capture
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> (string, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
-> string t
|
-> 'a t
|
||||||
val run_capture_line
|
val run_capture_line
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> (string, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
-> string t
|
-> 'a t
|
||||||
val run_capture_lines
|
val run_capture_lines
|
||||||
: ?dir:string
|
: ?dir:string
|
||||||
-> ?env:string array
|
-> ?env:string array
|
||||||
|
-> (string list, 'a) failure_mode
|
||||||
-> string
|
-> string
|
||||||
-> string list
|
-> string list
|
||||||
-> string list t
|
-> 'a t
|
||||||
|
|
||||||
module Scheduler : sig
|
module Scheduler : sig
|
||||||
val go : ?log:out_channel -> 'a t -> 'a
|
val go : ?log:out_channel -> 'a t -> 'a
|
||||||
|
|
|
@ -1175,7 +1175,7 @@ module Gen(P : Params) = struct
|
||||||
~dep_graph
|
~dep_graph
|
||||||
~modules
|
~modules
|
||||||
~mode
|
~mode
|
||||||
[String.capitalize name]))
|
[String.capitalize_ascii name]))
|
||||||
>>>
|
>>>
|
||||||
Build.run
|
Build.run
|
||||||
(Dep compiler)
|
(Dep compiler)
|
||||||
|
|
|
@ -79,7 +79,7 @@ end
|
||||||
context_file_contents
|
context_file_contents
|
||||||
(Path.to_string file)
|
(Path.to_string file)
|
||||||
(read_file (Path.to_string file));
|
(read_file (Path.to_string file));
|
||||||
run ~dir:(Path.to_string dir) ~env:context.env
|
Future.run Strict ~dir:(Path.to_string dir) ~env:context.env
|
||||||
(Path.to_string context.Context.ocaml)
|
(Path.to_string context.Context.ocaml)
|
||||||
[ Path.reach ~from:dir wrapper
|
[ Path.reach ~from:dir wrapper
|
||||||
; Path.reach ~from:dir generated_jbuild
|
; Path.reach ~from:dir generated_jbuild
|
||||||
|
|
|
@ -33,7 +33,7 @@ let module_name sexp =
|
||||||
String.iter s ~f:(function
|
String.iter s ~f:(function
|
||||||
| 'A'..'Z' | 'a'..'z' | '_' -> ()
|
| 'A'..'Z' | 'a'..'z' | '_' -> ()
|
||||||
| _ -> invalid_module_name sexp);
|
| _ -> invalid_module_name sexp);
|
||||||
String.capitalize s
|
String.capitalize_ascii s
|
||||||
|
|
||||||
let module_names sexp = String_set.of_list (list module_name sexp)
|
let module_names sexp = String_set.of_list (list module_name sexp)
|
||||||
|
|
||||||
|
|
|
@ -75,7 +75,7 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
|
||||||
(map_fname start.pos_fname) start.pos_lnum start_c stop_c msg
|
(map_fname start.pos_fname) start.pos_lnum start_c stop_c msg
|
||||||
| Fatal_error "" -> ()
|
| Fatal_error "" -> ()
|
||||||
| Fatal_error msg ->
|
| Fatal_error msg ->
|
||||||
Format.fprintf ppf "%s\n" (String.capitalize msg)
|
Format.fprintf ppf "%s\n" (String.capitalize_ascii msg)
|
||||||
| Findlib.Package_not_found pkg ->
|
| Findlib.Package_not_found pkg ->
|
||||||
Format.fprintf ppf "@{<error>Findlib package %S not found.@}\n" pkg
|
Format.fprintf ppf "@{<error>Findlib package %S not found.@}\n" pkg
|
||||||
| Code_error msg ->
|
| Code_error msg ->
|
||||||
|
|
Loading…
Reference in New Issue