Add a Log module and print out the context in the log file

bin/main.ml

@@ -37,8 +37,9 @@ let set_common c =
 module Main = struct
   include Jbuilder.Main
 
-  let setup ?filter_out_optional_stanzas_with_missing_deps common =
+  let setup ~log ?filter_out_optional_stanzas_with_missing_deps common =
     setup
+      ~log
       ?workspace_file:common.workspace_file
       ?only_packages:common.only_packages
       ?filter_out_optional_stanzas_with_missing_deps ()
@@ -47,8 +48,6 @@ end
 let do_build (setup : Main.setup) targets =
   Build_system.do_build_exn setup.build_system targets
 
-let create_log = Main.create_log
-
 type ('a, 'b) walk_result =
   | Cont of 'a
   | Stop of 'b
@@ -220,7 +219,7 @@ let installed_libraries =
   let doc = "Print out libraries installed on the system." in
   let go common =
     set_common common;
-    Future.Scheduler.go ~log:(create_log ())
+    Future.Scheduler.go ~log:(Log.create ())
       (Context.default () >>= fun ctx ->
        let findlib = ctx.findlib in
        let pkgs = Findlib.all_packages findlib in
@@ -318,8 +317,9 @@ let build_targets =
   let name_ = Arg.info [] ~docv:"TARGET" in
   let go common targets =
     set_common common;
-    Future.Scheduler.go ~log:(create_log ())
-      (Main.setup common >>= fun setup ->
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common >>= fun setup ->
        let targets = resolve_targets common setup targets in
        do_build setup targets) in
   ( Term.(const go
@@ -339,8 +339,9 @@ let runtest =
   let name_ = Arg.info [] ~docv:"DIR" in
   let go common dirs =
     set_common common;
-    Future.Scheduler.go ~log:(create_log ())
-      (Main.setup common >>= fun setup ->
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common >>= fun setup ->
        let targets =
          List.map dirs ~f:(fun dir ->
            let dir = Path.(relative root) (prefix_target common dir) in
@@ -364,8 +365,9 @@ let external_lib_deps =
   in
   let go common only_missing targets =
     set_common common;
-    Future.Scheduler.go ~log:(create_log ())
-      (Main.setup common ~filter_out_optional_stanzas_with_missing_deps:false
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common ~filter_out_optional_stanzas_with_missing_deps:false
        >>= fun setup ->
        let targets = resolve_targets common setup targets in
        let failure =
@@ -456,8 +458,9 @@ let install_uninstall ~what =
   let go common prefix pkgs =
     set_common common;
     let opam_installer = opam_installer () in
-    Future.Scheduler.go ~log:(create_log ())
-      (Main.setup common >>= fun setup ->
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common >>= fun setup ->
        let pkgs =
          match pkgs with
          | [] -> String_map.keys setup.packages
@@ -526,8 +529,9 @@ let exec =
   in
   let go common context prog args =
     set_common common;
-    Future.Scheduler.go ~log:(create_log ())
-      (Main.setup common >>= fun setup ->
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (Main.setup ~log common >>= fun setup ->
        let context =
          match List.find setup.contexts ~f:(fun c -> c.name = context) with
          | Some ctx -> ctx

src/future.ml

@@ -304,50 +304,11 @@ module Scheduler = struct
     ; output_filename : string
     ; (* for logs, with ansi colors code always included in the string *)
       command_line    : string
-    ; log             : out_channel option
+    ; log             : Log.t
     }
 
   let running = Hashtbl.create 128
 
-  let signal_name =
-    let table =
-      let open Sys in
-      [ sigabrt   , "ABRT"
-      ; sigalrm   , "ALRM"
-      ; sigfpe    , "FPE"
-      ; sighup    , "HUP"
-      ; sigill    , "ILL"
-      ; sigint    , "INT"
-      ; sigkill   , "KILL"
-      ; sigpipe   , "PIPE"
-      ; sigquit   , "QUIT"
-      ; sigsegv   , "SEGV"
-      ; sigterm   , "TERM"
-      ; sigusr1   , "USR1"
-      ; sigusr2   , "USR2"
-      ; sigchld   , "CHLD"
-      ; sigcont   , "CONT"
-      ; sigstop   , "STOP"
-      ; sigtstp   , "TSTP"
-      ; sigttin   , "TTIN"
-      ; sigttou   , "TTOU"
-      ; sigvtalrm , "VTALRM"
-      ; sigprof   , "PROF"
-      (* These ones are only available in OCaml >= 4.03 *)
-      ; -22       , "BUS"
-      ; -23       , "POLL"
-      ; -24       , "SYS"
-      ; -25       , "TRAP"
-      ; -26       , "URG"
-      ; -27       , "XCPU"
-      ; -28       , "XFSZ"
-      ]
-    in
-    fun n ->
-      match List.assoc n table with
-      | exception Not_found -> sprintf "%d\n" n
-      | s -> s
-
   let process_done ?(exiting=false) job (status : Unix.process_status) =
     Hashtbl.remove running job.pid;
     let output =
@@ -359,17 +320,10 @@ module Scheduler = struct
         s
     in
     Temp.destroy 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 %s]\n" (signal_name n)
-       | WSTOPPED  _ -> assert false);
-      flush oc
-    );
+    Log.command job.log
+      ~command_line:job.command_line
+      ~output:output
+      ~exit_status:status;
     if not exiting then begin
       match status with
       | WEXITED n when List.mem n ~set:job.job.ok_codes ->
@@ -390,7 +344,7 @@ module Scheduler = struct
       | WSIGNALED n ->
         Format.eprintf "\n@{<kwd>Command@} [@{<id>%d@}] got signal %s:\n\
                         @{<prompt>$@} %s\n%s%!"
-          job.id (signal_name n)
+          job.id (Utils.signal_name n)
           (Ansi_color.strip_colors_for_stderr job.command_line)
           (Ansi_color.strip_colors_for_stderr output);
         die ""
@@ -511,7 +465,7 @@ module Scheduler = struct
       end;
       go_rec cwd log t
 
-  let go ?log t =
+  let go ?(log=Log.no_log) t =
     Lazy.force Ansi_color.setup_env_for_ocaml_colors;
     let cwd = Sys.getcwd () in
     go_rec cwd log t

src/future.mli

@@ -74,7 +74,7 @@ val run_capture_lines
   -> 'a t
 
 module Scheduler : sig
-  val go : ?log:out_channel -> 'a t -> 'a
+  val go : ?log:Log.t -> 'a t -> 'a
 
   (** Executes [f] before exiting, after all pending commands have finished *)
   val at_exit_after_waiting_for_commands : (unit -> unit) -> unit

src/gen_rules.ml

@@ -1599,7 +1599,7 @@ module Gen(P : Params) = struct
       |> function
       | Ok x -> x
       | Error (name, f1, f2) ->
-        die "too many for module %s in %s: %s and %s"
+        die "too many files for module %s in %s: %s and %s"
           name (Path.to_string dir) f1 f2
     in
     let impls = parse_one_set ml_files  in

src/import.ml

@@ -253,6 +253,27 @@ module String = struct
         loop i (j + 1)
     in
     loop 0 0
+
+  let split_lines s =
+    let rec loop ~last_is_cr i j =
+      if j = length s then (
+        if j = i || (j = i + 1 && last_is_cr) then
+          []
+        else
+          [sub s ~pos:i ~len:(j - i)]
+      ) else
+        match s.[j] with
+        | '\r' -> loop ~last_is_cr:true i (j + 1)
+        | '\n' ->
+          let line =
+            let len = if last_is_cr then j - i - 1 else j - i in
+            sub s ~pos:i ~len
+          in
+          line :: loop (j + 1) (j + 1) ~last_is_cr:false
+        | _ ->
+          loop i (j + 1) ~last_is_cr:false
+    in
+    loop 0 0 ~last_is_cr:false
 end
 
 module Filename = struct

src/log.ml

@@ -0,0 +1,61 @@
+open Import
+
+type real =
+  { oc  : out_channel
+  ; buf : Buffer.t
+  ; ppf : Format.formatter
+  }
+
+type t = real option
+
+let no_log = None
+
+let create () =
+  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:" ");
+  let buf = Buffer.create 1024 in
+  let ppf = Format.formatter_of_buffer buf in
+  Some { oc; buf; ppf }
+
+let info_internal { oc; _ } str =
+  List.iter (String.split_lines str) ~f:(function
+    | "" -> output_string oc "#\n"
+    | s  -> Printf.fprintf oc "# %s\n" s);
+  flush oc
+
+let info t str =
+  match t with
+  | None -> ()
+  | Some t -> info_internal t str
+
+let infof t fmt =
+  match t with
+  | None -> Format.ikfprintf ignore Format.str_formatter fmt
+  | Some t ->
+    Format.kfprintf
+      (fun ppf ->
+         Format.pp_print_flush ppf ();
+         let s = Buffer.contents t.buf in
+         Buffer.clear t.buf;
+         info_internal t s)
+      t.ppf
+      fmt
+
+let command t ~command_line ~output ~exit_status =
+  match t with
+  | None -> ()
+  | Some { oc; _ } ->
+    Printf.fprintf oc "$ %s\n" (Ansi_color.strip command_line);
+    List.iter (String.split_lines output) ~f:(fun s ->
+      match Ansi_color.strip s with
+      | "" -> output_string oc ">\n"
+      | s  -> Printf.fprintf oc "> %s\n" s);
+    (match (exit_status : Unix.process_status) with
+     | WEXITED   0 -> ()
+     | WEXITED   n -> Printf.fprintf oc "[%d]\n" n
+     | WSIGNALED n -> Printf.fprintf oc "[got signal %s]\n" (Utils.signal_name n)
+     | WSTOPPED  _ -> assert false);
+    flush oc

src/log.mli

@@ -0,0 +1,22 @@
+(** Log file *)
+
+type t
+
+val no_log : t
+
+val create : unit -> t
+
+(** Print an information message in the log *)
+val info  : t -> string -> unit
+val infof : t -> ('a, Format.formatter, unit, unit) format4 -> 'a
+
+(** Print an executed command in the log *)
+val command
+  :  t
+  -> command_line:string
+  -> output:string
+  -> exit_status:Unix.process_status
+  -> unit
+
+
+

src/main.ml

@@ -13,7 +13,7 @@ let package_install_file { packages; _ } pkg =
   | None -> Error ()
   | Some p -> Ok (Path.relative p.path (p.name ^ ".install"))
 
-let setup ?filter_out_optional_stanzas_with_missing_deps
+let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps
       ?workspace ?(workspace_file="jbuild-workspace")
       ?only_packages () =
   let conf = Jbuild_load.load () in
@@ -39,6 +39,8 @@ let setup ?filter_out_optional_stanzas_with_missing_deps
      | Opam { name; switch; root; merlin } ->
        Context.create_for_opam ~name ~switch ?root ~merlin ()))
   >>= fun contexts ->
+  List.iter contexts ~f:(fun ctx ->
+    Log.infof log "@[<1>Jbuilder context:@,%a@]@." Sexp.pp (Context.sexp_of_t ctx));
   Gen_rules.gen conf ~contexts
     ?only_packages
     ?filter_out_optional_stanzas_with_missing_deps
@@ -117,14 +119,6 @@ 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 () =
   Ansi_color.setup_err_formatter_colors ();
@@ -137,8 +131,9 @@ let bootstrap () =
       ; "--debug-rules", Set Clflags.debug_rules    , " print out rules"
       ]
       anon "Usage: boot.exe [-j JOBS] [--dev]\nOptions are:";
-    Future.Scheduler.go ~log:(create_log ())
-      (setup ~workspace:{ merlin_context = Some "default"; contexts = [Default] } ()
+    let log = Log.create () in
+    Future.Scheduler.go ~log
+      (setup ~log ~workspace:{ merlin_context = Some "default"; contexts = [Default] } ()
        >>= fun { build_system = bs; _ } ->
        Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
   in

src/main.mli

@@ -12,19 +12,18 @@ type setup =
 val package_install_file : setup -> string -> (Path.t, unit) result
 
 val setup
-  :  ?filter_out_optional_stanzas_with_missing_deps:bool
+  :  ?log:Log.t
+  -> ?filter_out_optional_stanzas_with_missing_deps:bool
   -> ?workspace:Workspace.t
   -> ?workspace_file:string
   -> ?only_packages:String_set.t
   -> unit
   -> setup Future.t
 val external_lib_deps
-  : ?log:out_channel
+  : ?log:Log.t
   -> packages:string list
   -> unit
   -> 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

src/sexp.ml

@@ -23,6 +23,26 @@ let rec to_string = function
   | Atom s -> if must_escape s then sprintf "%S" s else s
   | List l -> sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ")
 
+let rec pp ppf = function
+  | Atom s ->
+    if must_escape s then
+      Format.fprintf ppf "%S" s
+    else
+      Format.pp_print_string ppf s
+  | List [] ->
+    Format.pp_print_string ppf "()"
+  | List (first :: rest) ->
+    Format.pp_open_box ppf 1;
+    Format.pp_print_string ppf "(";
+    Format.pp_open_hvbox ppf 0;
+    pp ppf first;
+    List.iter rest ~f:(fun sexp ->
+      Format.pp_print_space ppf ();
+      pp ppf sexp);
+    Format.pp_close_box ppf ();
+    Format.pp_print_string ppf ")";
+    Format.pp_close_box ppf ()
+
 let code_error message vars =
   code_errorf "%s"
     (to_string

src/sexp.mli

@@ -22,6 +22,8 @@ val code_error : string -> (string * t) list -> _
 
 val to_string : t -> string
 
+val pp : Format.formatter -> t -> unit
+
 module type Combinators = sig
   type 'a t
   val unit       : unit                      t

src/utils.ml

@@ -18,3 +18,42 @@ let system_shell =
          die "I need %s to %s but I couldn't find it :(\n\
               Who doesn't have %s%s?!"
            cmd needed_to cmd os })
+
+let signal_name =
+  let table =
+    let open Sys in
+    [ sigabrt   , "ABRT"
+    ; sigalrm   , "ALRM"
+    ; sigfpe    , "FPE"
+    ; sighup    , "HUP"
+    ; sigill    , "ILL"
+    ; sigint    , "INT"
+    ; sigkill   , "KILL"
+    ; sigpipe   , "PIPE"
+    ; sigquit   , "QUIT"
+    ; sigsegv   , "SEGV"
+    ; sigterm   , "TERM"
+    ; sigusr1   , "USR1"
+    ; sigusr2   , "USR2"
+    ; sigchld   , "CHLD"
+    ; sigcont   , "CONT"
+    ; sigstop   , "STOP"
+    ; sigtstp   , "TSTP"
+    ; sigttin   , "TTIN"
+    ; sigttou   , "TTOU"
+    ; sigvtalrm , "VTALRM"
+    ; sigprof   , "PROF"
+    (* These ones are only available in OCaml >= 4.03 *)
+    ; -22       , "BUS"
+    ; -23       , "POLL"
+    ; -24       , "SYS"
+    ; -25       , "TRAP"
+    ; -26       , "URG"
+    ; -27       , "XCPU"
+    ; -28       , "XFSZ"
+    ]
+  in
+  fun n ->
+    match List.assoc n table with
+    | exception Not_found -> sprintf "%d\n" n
+    | s -> s

src/utils.mli

@@ -5,3 +5,6 @@ open Import
 (** Return the absolute path to the shell, the argument to pass it (-c or /c) and a
     failure in case the shell can't be found. *)
 val system_shell : needed_to:string -> Path.t * string * fail option
+
+(** Convert a signal number to a name: INT, TERM, ... *)
+val signal_name : int -> string