Allow 'ocamlfind printconf path' to fail

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

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

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 ->

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 =

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 "@{<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

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

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)

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

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)
 

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 "@{<error>Findlib package %S not found.@}\n" pkg
   | Code_error msg ->