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 ->
|
||||
Future.all_unit
|
||||
(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]
|
||||
; "--prefix"
|
||||
; Path.to_string prefix
|
||||
|
|
|
@ -7,8 +7,11 @@ module List = ListLabels
|
|||
module String = struct
|
||||
include StringLabels
|
||||
|
||||
let capitalize_ascii = String.capitalize_ascii
|
||||
let uncapitalize_ascii = String.uncapitalize_ascii
|
||||
include struct
|
||||
[@@@warning "-3"]
|
||||
let capitalize_ascii = String.capitalize
|
||||
let uncapitalize_ascii = String.uncapitalize
|
||||
end
|
||||
end
|
||||
|
||||
open Printf
|
||||
|
@ -269,7 +272,7 @@ end
|
|||
output_string oc s;
|
||||
pos_in_generated_file := !pos_in_generated_file + count_newlines s;
|
||||
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 ml = sprintf "src/%s.ml" base in
|
||||
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
|
||||
(fun (prog, args) ->
|
||||
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)
|
||||
|
||||
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
|
||||
(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 =
|
||||
run_capture_gen ~f:Future.run_capture ?dir ?env prog args
|
||||
|
@ -181,8 +182,8 @@ let action ~targets =
|
|||
List.iter touches ~f:(fun fn ->
|
||||
close_out (open_out_bin (Path.to_string fn)));
|
||||
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)
|
||||
args)
|
||||
Future.run Strict ~dir:(Path.to_string dir) ~env ?stdout_to
|
||||
(Path.reach ~from:dir prog) args)
|
||||
|
||||
let echo fn =
|
||||
create_file ~target:fn (fun data ->
|
||||
|
|
|
@ -80,7 +80,7 @@ let opam_config_var ~env ~cache var =
|
|||
match Bin.opam with
|
||||
| None -> return None
|
||||
| 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 ->
|
||||
let s = String.trim s in
|
||||
Hashtbl.add cache ~key:var ~data:s;
|
||||
|
@ -126,8 +126,11 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin =
|
|||
| None ->
|
||||
return []
|
||||
| Some fn ->
|
||||
Future.run_capture_lines ~env (Path.to_string fn) ["printconf"; "path"]
|
||||
>>| List.map ~f:Path.absolute)
|
||||
Future.run_capture_lines ~env (Accept [127])
|
||||
(Path.to_string fn) ["printconf"; "path"]
|
||||
>>| function
|
||||
| Ok lines -> List.map lines ~f:Path.absolute
|
||||
| Error _ -> [])
|
||||
>>| fun (a, b) ->
|
||||
match a @ b with
|
||||
| [] -> [Path.relative (Path.parent dir) "lib"]
|
||||
|
@ -138,7 +141,7 @@ let create ~(kind : Kind.t) ~path ~env ~name ~merlin =
|
|||
else
|
||||
x :: acc)
|
||||
|> 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) ->
|
||||
let ocamlc_config =
|
||||
List.map ocamlc_config ~f:(fun line ->
|
||||
|
@ -272,9 +275,9 @@ let create_for_opam ?root ~switch ~name ?(merlin=false) () =
|
|||
(match root with
|
||||
| Some root -> return root
|
||||
| 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 ->
|
||||
Future.run_capture (Path.to_string fn)
|
||||
Future.run_capture Strict (Path.to_string fn)
|
||||
["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"]
|
||||
>>= fun s ->
|
||||
let vars =
|
||||
|
|
|
@ -134,48 +134,89 @@ let rec all_unit = function
|
|||
x >>= fun () ->
|
||||
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 =
|
||||
{ prog : string
|
||||
; args : string list
|
||||
; dir : string option
|
||||
; stdout_to : string 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 run ?dir ?stdout_to ?env prog args =
|
||||
let run_internal ?dir ?stdout_to ?env fail_mode prog args =
|
||||
let dir =
|
||||
match dir with
|
||||
| Some "." -> None
|
||||
| _ -> dir
|
||||
in
|
||||
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 () =
|
||||
let run ?dir ?stdout_to ?env fail_mode prog args =
|
||||
map_result fail_mode (run_internal ?dir ?stdout_to ?env fail_mode prog args)
|
||||
~f:ignore
|
||||
|
||||
module Temp = struct
|
||||
let tmp_files = ref String_set.empty
|
||||
let () =
|
||||
at_exit (fun () ->
|
||||
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 =
|
||||
let fn = Filename.temp_file "jbuild" ".output" in
|
||||
let create prefix suffix =
|
||||
let fn = Filename.temp_file prefix suffix in
|
||||
tmp_files := String_set.add fn !tmp_files;
|
||||
run ?dir ~stdout_to:fn ?env prog args >>= fun () ->
|
||||
let s = f fn in
|
||||
fn
|
||||
|
||||
let destroy fn =
|
||||
Sys.remove fn;
|
||||
tmp_files := String_set.remove fn !tmp_files;
|
||||
return s
|
||||
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_lines = run_capture_gen ~f:lines_of_file
|
||||
|
||||
let run_capture_line ?dir ?env prog args =
|
||||
run_capture_lines ?dir ?env prog args >>| function
|
||||
let run_capture_line ?dir ?env fail_mode prog args =
|
||||
run_capture_gen ?dir ?env fail_mode prog args ~f:(fun fn ->
|
||||
match lines_of_file fn with
|
||||
| [x] -> x
|
||||
| l ->
|
||||
let cmdline =
|
||||
|
@ -189,7 +230,7 @@ let run_capture_line ?dir ?env prog args =
|
|||
die "command returned nothing: %s" cmdline
|
||||
| _ ->
|
||||
die "command returned too many lines: %s\n%s"
|
||||
cmdline (String.concat l ~sep:"\n")
|
||||
cmdline (String.concat l ~sep:"\n"))
|
||||
|
||||
module Scheduler = struct
|
||||
let colorize_prog s =
|
||||
|
@ -302,7 +343,7 @@ module Scheduler = struct
|
|||
else
|
||||
s
|
||||
in
|
||||
Sys.remove job.output_filename;
|
||||
Temp.destroy job.output_filename;
|
||||
Option.iter job.log ~f:(fun oc ->
|
||||
Printf.fprintf oc "$ %s\n%s"
|
||||
(Ansi_color.strip job.command_line)
|
||||
|
@ -316,10 +357,14 @@ module Scheduler = struct
|
|||
);
|
||||
if not exiting then begin
|
||||
match status with
|
||||
| WEXITED 0 ->
|
||||
| WEXITED n when List.mem n ~set:job.job.ok_codes ->
|
||||
if output <> "" then
|
||||
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 ->
|
||||
Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] exited with code %d:\n\
|
||||
@{<prompt>$@} %s\n%s%!"
|
||||
|
@ -380,7 +425,7 @@ module Scheduler = struct
|
|||
Format.eprintf "@{<kwd>Running@}[@{<id>%d@}]: %s@." id
|
||||
(Ansi_color.strip_colors_for_stderr command_line);
|
||||
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 stdout, close_stdout =
|
||||
match job.stdout_to with
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
(** Simplified Async/Lwt like monad *)
|
||||
|
||||
open Import
|
||||
|
||||
type '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
|
||||
|
||||
(** 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 *)
|
||||
val run
|
||||
: ?dir:string
|
||||
-> ?stdout_to:string
|
||||
-> ?env:string array
|
||||
-> (unit, 'a) failure_mode
|
||||
-> string
|
||||
-> string list
|
||||
-> unit t
|
||||
-> 'a t
|
||||
|
||||
(** Run a command and capture its output *)
|
||||
val run_capture
|
||||
: ?dir:string
|
||||
-> ?env:string array
|
||||
-> (string, 'a) failure_mode
|
||||
-> string
|
||||
-> string list
|
||||
-> string t
|
||||
-> 'a t
|
||||
val run_capture_line
|
||||
: ?dir:string
|
||||
-> ?env:string array
|
||||
-> (string, 'a) failure_mode
|
||||
-> string
|
||||
-> string list
|
||||
-> string t
|
||||
-> 'a t
|
||||
val run_capture_lines
|
||||
: ?dir:string
|
||||
-> ?env:string array
|
||||
-> (string list, 'a) failure_mode
|
||||
-> string
|
||||
-> string list
|
||||
-> string list t
|
||||
-> 'a t
|
||||
|
||||
module Scheduler : sig
|
||||
val go : ?log:out_channel -> 'a t -> 'a
|
||||
|
|
|
@ -1175,7 +1175,7 @@ module Gen(P : Params) = struct
|
|||
~dep_graph
|
||||
~modules
|
||||
~mode
|
||||
[String.capitalize name]))
|
||||
[String.capitalize_ascii name]))
|
||||
>>>
|
||||
Build.run
|
||||
(Dep compiler)
|
||||
|
|
|
@ -79,7 +79,7 @@ end
|
|||
context_file_contents
|
||||
(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.reach ~from:dir wrapper
|
||||
; Path.reach ~from:dir generated_jbuild
|
||||
|
|
|
@ -33,7 +33,7 @@ let module_name sexp =
|
|||
String.iter s ~f:(function
|
||||
| 'A'..'Z' | 'a'..'z' | '_' -> ()
|
||||
| _ -> invalid_module_name sexp);
|
||||
String.capitalize s
|
||||
String.capitalize_ascii s
|
||||
|
||||
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
|
||||
| Fatal_error "" -> ()
|
||||
| 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 ->
|
||||
Format.fprintf ppf "@{<error>Findlib package %S not found.@}\n" pkg
|
||||
| Code_error msg ->
|
||||
|
|
Loading…
Reference in New Issue