diff --git a/bin/main.ml b/bin/main.ml index 49cc9f05..d4c45a6c 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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 diff --git a/bootstrap.ml b/bootstrap.ml index 72b9a718..9a0af296 100644 --- a/bootstrap.ml +++ b/bootstrap.ml @@ -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 diff --git a/src/build.ml b/src/build.ml index 6b2d6c72..c5e12984 100644 --- a/src/build.ml +++ b/src/build.ml @@ -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 -> diff --git a/src/context.ml b/src/context.ml index b2808b13..841d45c5 100644 --- a/src/context.ml +++ b/src/context.ml @@ -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 = diff --git a/src/future.ml b/src/future.ml index bfcf4a1a..e18fc8b4 100644 --- a/src/future.ml +++ b/src/future.ml @@ -134,62 +134,103 @@ 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 () = - 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 ?dir ?stdout_to ?env fail_mode prog args = + map_result fail_mode (run_internal ?dir ?stdout_to ?env fail_mode prog args) + ~f:ignore -let run_capture_gen ?dir ?env prog args ~f = - let fn = Filename.temp_file "jbuild" ".output" in - tmp_files := String_set.add fn !tmp_files; - run ?dir ~stdout_to:fn ?env prog args >>= fun () -> - let s = f fn in - Sys.remove fn; - tmp_files := String_set.remove fn !tmp_files; - return s +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 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_lines = run_capture_gen ~f:lines_of_file -let run_capture_line ?dir ?env prog args = - run_capture_lines ?dir ?env prog args >>| function - | [x] -> x - | l -> - let cmdline = - let s = String.concat (prog :: args) ~sep:" " in - match dir with - | None -> s - | Some dir -> sprintf "cd %s && %s" dir s - in - match l with - | [] -> - die "command returned nothing: %s" cmdline - | _ -> - die "command returned too many lines: %s\n%s" - cmdline (String.concat l ~sep:"\n") +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 = + let s = String.concat (prog :: args) ~sep:" " in + match dir with + | None -> s + | Some dir -> sprintf "cd %s && %s" dir s + in + match l with + | [] -> + die "command returned nothing: %s" cmdline + | _ -> + die "command returned too many lines: %s\n%s" + 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 "@{Output@}[@{%d@}]:\n%s%!" job.id output; - Ivar.fill job.job.ivar () + if n <> 0 then + Format.eprintf + "@{Warning@}: Command [@{%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@{Command@} [@{%d@}] exited with code %d:\n\ @{$@} %s\n%s%!" @@ -380,7 +425,7 @@ module Scheduler = struct Format.eprintf "@{Running@}[@{%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 diff --git a/src/future.mli b/src/future.mli index a2f099df..9d00e9f7 100644 --- a/src/future.mli +++ b/src/future.mli @@ -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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 77e9e5a8..e36be05c 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1175,7 +1175,7 @@ module Gen(P : Params) = struct ~dep_graph ~modules ~mode - [String.capitalize name])) + [String.capitalize_ascii name])) >>> Build.run (Dep compiler) diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index e1718a1b..2e3fe1ef 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -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 diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index c49e6e1d..8219282f 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -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) diff --git a/src/main.ml b/src/main.ml index 1b83d5d4..61c64a8b 100644 --- a/src/main.ml +++ b/src/main.ml @@ -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 "@{Findlib package %S not found.@}\n" pkg | Code_error msg ->