Don't mangle the output of commands and keep a log file

bin/main.ml

@@ -6,12 +6,14 @@ module Main = Jbuilder.Main
 
 let (>>=) = Future.(>>=)
 
+let create_log = Main.create_log
+
 (* TODO: rewrite this when command trees are supported.
 
    https://github.com/dbuenzli/cmdliner/issues/24 *)
 let internal = function
   | [_; "findlib-packages"] ->
-    Future.Scheduler.go
+    Future.Scheduler.go ~log:(create_log ())
       (Lazy.force Context.default >>= fun ctx ->
        let findlib = Findlib.create ctx in
        let pkgs = Findlib.all_packages findlib in
@@ -71,7 +73,7 @@ let common =
   Term.(const make $ concurrency $ drules $ ddep_path $ dfindlib)
 
 let build_package pkg =
-  Future.Scheduler.go
+  Future.Scheduler.go ~log:(create_log ())
     (Main.setup () >>= fun (bs, _, _) ->
      Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
 
@@ -88,8 +90,9 @@ let build_package =
   , Term.info "build-package" ~doc ~man:help_secs)
 
 let external_lib_deps packages =
+  let log = create_log () in
   let deps =
-    Path.Map.fold (Main.external_lib_deps ~packages) ~init:String_map.empty
+    Path.Map.fold (Main.external_lib_deps ~log ~packages) ~init:String_map.empty
       ~f:(fun ~key:_ ~data:deps acc -> Build.merge_lib_deps deps acc)
   in
   String_map.iter deps ~f:(fun ~key:n ~data ->
@@ -136,7 +139,7 @@ let build_targets ~name =
   let name_ = Arg.info [] ~docv:"TARGET" in
   let go common targets =
     set_common common;
-    Future.Scheduler.go
+    Future.Scheduler.go ~log:(create_log ())
       (Main.setup () >>= fun (bs, _, ctx) ->
        let targets = resolve_targets bs ctx targets in
        Build_system.do_build_exn bs targets) in

src/ansi_color.ml

@@ -87,3 +87,23 @@ let colorize =
     let hash = Hashtbl.hash key in
     let fore, back = color_combos.(hash mod (Array.length color_combos)) in
     apply_string [Foreground fore; Background back] str
+
+let strip str =
+  let len = String.length str in
+  let buf = Buffer.create len in
+  let rec loop i =
+    if i = len then
+      Buffer.contents buf
+    else
+      match str.[i] with
+      | '\027' -> skip (i + 1)
+      | c      -> Buffer.add_char buf c; loop (i + 1)
+  and skip i =
+    if i = len then
+      Buffer.contents buf
+    else
+      match str.[i] with
+      | 'm' -> loop (i + 1)
+      | _   -> skip (i + 1)
+  in
+  loop 0

src/ansi_color.mli

@@ -1 +1,2 @@
 val colorize : key:string -> string -> string
+val strip : string -> string

src/future.ml

@@ -192,47 +192,17 @@ let run_capture_line ?dir ?env prog args =
         cmdline (String.concat l ~sep:"\n")
 
 module Scheduler = struct
-  let quote s =
-    let len = String.length s in
-    if len = 0 then
-      Filename.quote s
-    else
-      let rec loop i =
-        if i = len then
-          s
-        else
-          match s.[i] with
-          | ' ' | '\"' -> Filename.quote s
-          | _ -> loop (i + 1)
-      in
-      loop 0
-
   let key_for_color prog =
     let s = Filename.basename prog in
     match String.lsplit2 s ~on:'.' with
     | None -> s
     | Some (s, _) -> s
 
-  let err_is_atty = lazy Unix.(isatty stderr)
-
-  let dumb_term =
-    match Sys.getenv "TERM" with
-    | exception Not_found -> true
-    | "dumb" -> true
-    | _ -> false
-
-  let command_line ?colorize { prog; args; dir; stdout_to; _ } =
-    let colorize =
-      match colorize with
-      | Some x -> x
-      | None -> not Sys.win32 && Lazy.force err_is_atty && not dumb_term
-    in
+  let command_line { prog; args; dir; stdout_to; _ } =
+    let quote = quote_for_shell in
     let prog =
       let s = quote prog in
-      if colorize then
-        Ansi_color.colorize ~key:(key_for_color prog) s
-      else
-        s
+      Ansi_color.colorize ~key:(key_for_color prog) s
     in
     let s = String.concat (prog :: List.map args ~f:quote) ~sep:" " in
     let s =
@@ -244,19 +214,70 @@ module Scheduler = struct
     | None -> s
     | Some dir -> sprintf "(cd %s && %s)" dir s
 
-  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 strip_colors_for_stderr =
+    let strip = lazy (
+      Sys.win32                  ||
+      not (Unix.(isatty stderr)) ||
+      match Sys.getenv "TERM" with
+      | exception Not_found -> true
+      | "dumb" -> true
+      | _ -> false
+    ) in
+    fun s ->
+      if Lazy.force strip then Ansi_color.strip s else s
 
-  let process_done job status =
-    handle_process_status (lazy (command_line job)) status;
-    Ivar.fill job.ivar ()
+  type running_job =
+    { id              : int
+    ; job             : job
+    ; pid             : int
+    ; output_filename : string
+    ; (* for logs, with ansi colors code always included in the string *)
+      command_line    : string
+    ; log             : out_channel option
+    }
 
   let running = Hashtbl.create 128
 
+  let handle_process_status job (status : Unix.process_status) =
+    match status with
+    | WEXITED   0 -> ()
+    | WEXITED   n -> die "Command [%d] exited with code %d"     job.id n
+    | WSIGNALED n -> die "Command [%d] got killed by signal %d" job.id n
+    | WSTOPPED  _ -> assert false
+
+  let process_done ?(exiting=false) job (status : Unix.process_status) =
+    Hashtbl.remove running job.pid;
+    let output =
+      let s = read_file job.output_filename in
+      let len = String.length s in
+      if len > 0 && s.[len - 1] <> '\n' then
+        s ^ "\n"
+      else
+        s
+    in
+    Sys.remove job.output_filename;
+    Option.iter job.log ~f:(fun oc ->
+      Printf.fprintf oc "$ %s\n%s"
+        (Ansi_color.strip job.command_line)
+        (Ansi_color.strip output);
+      (match status with
+       | WEXITED   0 -> ()
+       | WEXITED   n -> Printf.fprintf oc "[%d]\n" n
+       | WSIGNALED n -> Printf.fprintf oc "[got signal %d]\n" n
+       | WSTOPPED  _ -> assert false);
+      flush oc
+    );
+    if not exiting then begin
+      if output <> "" then
+        Printf.eprintf "Output[%d]:\n%s%!" job.id output;
+      handle_process_status job status;
+      Ivar.fill job.job.ivar ()
+    end
+
+  let gen_id =
+    let next = ref (-1) in
+    fun () -> incr next; !next
+
   let rec wait_win32 () =
     let finished =
       Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:job acc ->
@@ -272,49 +293,60 @@ module Scheduler = struct
       wait_win32 ()
     | _ ->
       List.iter finished ~f:(fun (pid, job, status) ->
-        Hashtbl.remove running pid;
         process_done job status)
 
   let () =
     at_exit (fun () ->
       let pids =
-        Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:_ acc -> pid :: acc)
+        Hashtbl.fold running ~init:[] ~f:(fun ~key:_ ~data:job acc -> job :: acc)
       in
-      List.iter pids ~f:(fun pid ->
-        ignore (Unix.waitpid [] pid : _ * _);
-        Hashtbl.remove running pid))
+      List.iter pids ~f:(fun job ->
+        let _, status = Unix.waitpid [] job.pid in
+        process_done job status ~exiting:true))
 
-  let rec go t =
-    let cwd = Sys.getcwd () in
+  let rec go_rec cwd log t =
     match (repr t).state with
     | Return v -> v
     | _ ->
       while Hashtbl.length running < !Clflags.concurrency &&
             not (Queue.is_empty to_run) do
         let job = Queue.pop to_run in
+        let id = gen_id () in
+        let command_line = command_line job in
         if !Clflags.debug_run then
-          Printf.eprintf "Running: %s\n%!" (command_line job);
+          Printf.eprintf "Running[%d]: %s\n%!" id
+            (strip_colors_for_stderr command_line);
+        Option.iter job.dir ~f:(fun dir -> Sys.chdir dir);
+        let argv = Array.of_list (job.prog :: job.args) in
+        let output_filename = Filename.temp_file "jbuilder" ".output" in
+        let output_fd = Unix.openfile output_filename [O_WRONLY] 0 in
         let stdout, close_stdout =
           match job.stdout_to with
-          | None -> (Unix.stdout, false)
+          | None -> (output_fd, false)
           | Some fn ->
             let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in
             (fd, true)
         in
-        Option.iter job.dir ~f:(fun dir -> Sys.chdir dir);
-        let argv = Array.of_list (job.prog :: job.args) in
         let pid =
           match job.env with
           | None ->
             Unix.create_process job.prog argv
-              Unix.stdin stdout Unix.stderr
+              Unix.stdin stdout output_fd
           | Some env ->
             Unix.create_process_env job.prog argv env
-              Unix.stdin stdout Unix.stderr
+              Unix.stdin stdout output_fd
         in
+        Unix.close output_fd;
         if close_stdout then Unix.close stdout;
         Option.iter job.dir ~f:(fun _ -> Sys.chdir cwd);
-        Hashtbl.add running ~key:pid ~data:job
+        Hashtbl.add running ~key:pid
+          ~data:{ id
+                ; job
+                ; pid
+                ; output_filename
+                ; command_line
+                ; log
+                }
       done;
       if Sys.win32 then
         wait_win32 ()
@@ -324,8 +356,11 @@ module Scheduler = struct
           Hashtbl.find_exn running pid ~string_of_key:(sprintf "<pid:%d>")
             ~table_desc:(fun _ -> "<running-jobs>")
         in
-        Hashtbl.remove running pid;
         process_done job status
       end;
-      go t
+      go_rec cwd log t
+
+  let go ?log t =
+    let cwd = Sys.getcwd () in
+    go_rec cwd log t
 end

src/future.mli

@@ -43,5 +43,5 @@ val run_capture_lines
   -> string list t
 
 module Scheduler : sig
-  val go : 'a t -> 'a
+  val go : ?log:out_channel -> 'a t -> 'a
 end

src/import.ml

@@ -348,3 +348,18 @@ end = struct
 end
 
 type fail = { fail : 'a. unit -> 'a }
+
+let quote_for_shell s =
+  let len = String.length s in
+  if len = 0 then
+    Filename.quote s
+  else
+    let rec loop i =
+      if i = len then
+        s
+      else
+        match s.[i] with
+        | ' ' | '\"' -> Filename.quote s
+        | _ -> loop (i + 1)
+    in
+    loop 0

src/main.ml

@@ -11,8 +11,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps () =
   let bs = Build_system.create ~file_tree ~rules in
   return (bs, stanzas, ctx)
 
-let external_lib_deps ~packages =
-  Future.Scheduler.go
+let external_lib_deps ?log ~packages =
+  Future.Scheduler.go ?log
     (setup () ~filter_out_optional_stanzas_with_missing_deps:false
      >>| fun (bs, stanzas, _) ->
      Path.Map.map
@@ -63,6 +63,14 @@ let report_error ?map_fname ppf exn =
     let backtrace = Printexc.get_raw_backtrace () in
     report_error ?map_fname ppf exn ~backtrace
 
+let create_log () =
+  if not (Sys.file_exists "_build") then
+    Unix.mkdir "_build" 0o777;
+  let oc = open_out_bin "_build/log" in
+  Printf.fprintf oc "# %s\n%!"
+    (String.concat (List.map (Array.to_list Sys.argv) ~f:quote_for_shell) ~sep:" ");
+  oc
+
 (* Called by the script generated by ../build.ml *)
 let bootstrap () =
   let pkg = "jbuilder" in
@@ -70,7 +78,7 @@ let bootstrap () =
     let anon s = raise (Arg.Bad (Printf.sprintf "don't know what to do with %s\n" s)) in
     Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ]
       anon "Usage: boot.exe [-j JOBS]\nOptions are:";
-    Future.Scheduler.go
+    Future.Scheduler.go ~log:(create_log ())
       (setup () >>= fun (bs, _, _) ->
        Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
   in

src/main.mli

@@ -4,7 +4,12 @@ val setup
   -> unit
   -> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.t)
        Future.t
-val external_lib_deps : packages:string list -> Build.lib_deps Path.Map.t
+val external_lib_deps
+  : ?log:out_channel
+  -> packages:string list
+  -> Build.lib_deps Path.Map.t
 val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit
 
 val bootstrap : unit -> unit
+
+val create_log : unit -> out_channel