Convert Process, Scheduler and Console to the new error r… (#2308)

Convert `Process`, `Scheduler` and `Console` to the new error reporting API and restore coloring

bin/install_uninstall.ml

@@ -222,20 +222,14 @@ let install_uninstall ~what =
                 with
                 | [] -> (package, entries)
                 | missing_files ->
-                  let pp =
-                    let open Pp in
-                    List.map missing_files ~f:(fun p ->
-                      concat
-                        [ verbatim "- "
-                        ; verbatim (Path.Build.to_string_maybe_quoted p)
-                        ]
-                    )
-                    |> concat ~sep:newline
-                  in
-                  die "The following files which are listed in %s cannot be \
-                       installed because they do not exist:@.%a@."
-                    (Path.to_string_maybe_quoted install_file)
-                    (fun fmt () -> Pp.pp fmt pp) ())
+                  User_error.raise
+                    [ Pp.textf
+                        "The following files which are listed in %s \
+                         cannot be installed because they do not exist:"
+                        (Path.to_string_maybe_quoted install_file)
+                    ; Pp.enumerate missing_files ~f:(fun p ->
+                        Pp.verbatim (Path.Build.to_string_maybe_quoted p))
+                    ])
           in
           (context, entries_per_package))
       in

bin/print_rules.ml

@@ -39,7 +39,7 @@ let print_rule_makefile ppf (rule : Build_system.Rule.t) =
     (fun ppf ->
        Path.Set.iter (Dep.Set.paths rule.deps ~eval_pred) ~f:(fun dep ->
          Format.fprintf ppf "@ %s" (Path.to_string dep)))
-    Pp.pp
+    Pp.render_ignore_tags
     (Action_to_sh.pp action)
 
 let print_rule_sexp ppf (rule : Build_system.Rule.t) =

src/colors.ml

@@ -1,38 +1,6 @@
 open! Stdune
 open Import
 
-type styles = Ansi_color.Style.t list
-
-let apply_string styles str =
-  sprintf "%s%s%s"
-    (Ansi_color.Style.escape_sequence styles)
-    str
-    (Ansi_color.Style.escape_sequence [])
-
-let colorize =
-  let color_combos =
-    let open Ansi_color.Color in
-    [| Blue,          Bright_green
-     ; Red,           Bright_yellow
-     ; Yellow,        Blue
-     ; Magenta,       Bright_cyan
-     ; Bright_green,  Blue
-     ; Bright_yellow, Red
-     ; Blue,          Yellow
-     ; Bright_cyan,   Magenta
-    |]
-  in
-  fun ~key str ->
-    let hash = Hashtbl.hash key in
-    let fore, back = color_combos.(hash mod (Array.length color_combos)) in
-    apply_string [Fg fore; Bg back] str
-
-let strip_colors_for_stderr s =
-  if Lazy.force Ansi_color.stderr_supports_color then
-    s
-  else
-    Ansi_color.strip s
-
 (* We redirect the output of all commands, so by default the various
    tools will disable colors. Since we support colors in the output of
    commands, we force it via specific environment variables if stderr
@@ -65,10 +33,11 @@ module Style = struct
     | _         -> None
 end
 
-let styles_of_tag s =
+let mark_open_tag s =
   match Style.of_string s with
-  | None -> []
-  | Some style -> Style.to_styles style
+  | Some style -> Ansi_color.Style.escape_sequence (Style.to_styles style)
+  | None ->
+    if s <> "" && s.[0] = '\027' then s else ""
 
 let setup_err_formatter_colors () =
   let open Format in
@@ -78,14 +47,7 @@ let setup_err_formatter_colors () =
       pp_set_mark_tags ppf true;
       pp_set_formatter_tag_functions ppf
         { funcs with
-          mark_close_tag = (fun _   -> Ansi_color.Style.escape_sequence [])
-        ; mark_open_tag  = (fun tag -> Ansi_color.Style.escape_sequence
-                                         (styles_of_tag tag))
+          mark_close_tag = (fun _ -> Ansi_color.Style.escape_sequence [])
+        ; mark_open_tag
         } [@warning "-3"])
   end
-
-let output_filename : styles = [Bold; Fg Green]
-
-let command_success : styles = [Bold; Fg Green]
-
-let command_error : styles = [Bold; Fg Red]

src/colors.mli

@@ -1,23 +1,8 @@
 open! Stdune
 
-val colorize : key:string -> string -> string
-
 (** [Env.initial] extended with variables to force a few tools to
     print colors *)
 val setup_env_for_colors : Env.t -> Env.t
 
-(** Strip colors in [not (Lazy.force Ansi_color.stderr_supports_colors)] *)
-val strip_colors_for_stderr : string -> string
-
 (** Enable the interpretation of color tags for [Format.err_formatter] *)
 val setup_err_formatter_colors : unit -> unit
-
-type styles
-
-val output_filename : styles
-
-val command_success : styles
-
-val command_error : styles
-
-val apply_string : styles -> string -> string

src/console.ml

@@ -1,69 +1,81 @@
 open! Stdune
 
 type status_line_config =
-  { message   : string option
+  { message   : User_message.Style.t Pp.t option
   ; show_jobs : bool
   }
 
 module T = struct
 
   type t = {
     display : Config0.Display.t;
-    mutable status_line : string;
+    mutable status_line : Ansi_color.Style.t list Pp.t;
+    mutable status_line_len : int;
     mutable gen_status_line : unit -> status_line_config;
   }
 
-  let hide_status_line s =
-    let len = String.length s in
-    if len > 0 then Printf.eprintf "\r%*s\r" len ""
+  let hide_status_line t =
+    if t.status_line_len > 0 then
+      Printf.eprintf "\r%*s\r" t.status_line_len ""
 
   let show_status_line s =
-    prerr_string s
+    Ansi_color.prerr s
 
   let update_status_line t ~running_jobs =
     if t.display = Progress then begin
       match t.gen_status_line () with
       | { message = None; _ } ->
-        if t.status_line <> "" then begin
-          hide_status_line t.status_line;
-          flush stderr
-        end
+        hide_status_line t;
+        flush stderr
       | { message = Some status_line; show_jobs } ->
         let status_line =
           if show_jobs then
-            sprintf "%s (jobs: %u)" status_line running_jobs
+            Pp.seq status_line
+              (Pp.verbatim (sprintf " (jobs: %u)" running_jobs))
           else
             status_line
         in
-        hide_status_line t.status_line;
-        show_status_line   status_line;
+        let status_line =
+          Pp.map_tags status_line ~f:User_message.Print_config.default
+        in
+        let status_line_len =
+          String.length (Format.asprintf "%a" Pp.render_ignore_tags status_line)
+        in
+        hide_status_line t;
+        show_status_line status_line;
         flush stderr;
         t.status_line <- status_line;
+        t.status_line_len <- status_line_len
     end
 
   let print t msg =
-    let s = t.status_line in
-    hide_status_line s;
+    hide_status_line t;
     prerr_string msg;
-    show_status_line s;
+    show_status_line t.status_line;
+    flush stderr
+
+  let print_user_message t ?config msg =
+    hide_status_line t;
+    User_message.prerr ?config msg;
+    show_status_line t.status_line;
     flush stderr
 
   let hide_status_line t =
-    hide_status_line t.status_line;
+    hide_status_line t;
     flush stderr
 
   let set_status_line_generator t f ~running_jobs =
     t.gen_status_line <- f;
     update_status_line t ~running_jobs
-
 end
 
 let t_var = ref None
 
 let init display =
   t_var := Some {
     T.display;
-    status_line = "";
+    status_line = Pp.nop;
+    status_line_len = 0;
     gen_status_line = (fun () -> { message = None; show_jobs = false; });
   }
 
@@ -81,3 +93,7 @@ let print msg =
   match !t_var with
   | None -> Printf.eprintf "%s%!" msg
   | Some t -> T.print t msg
+let print_user_message ?config msg =
+  match !t_var with
+  | None -> User_message.prerr ?config msg
+  | Some t -> T.print_user_message t ?config msg

src/console.mli

@@ -2,9 +2,13 @@ open! Stdune
 
 val print : string -> unit
 
+val print_user_message
+  :  ?config:User_message.Print_config.t
+  -> User_message.t
+  -> unit
 
 type status_line_config =
-  { message   : string option
+  { message   : User_message.Style.t Pp.t option
   ; show_jobs : bool
   }
 

src/main.ml

@@ -86,7 +86,8 @@ let init_build_system ?only_packages ?external_lib_deps_mode w =
   let rule_total = ref 0 in
   let gen_status_line () =
     { Console.
-      message = Some (sprintf "Done: %u/%u" !rule_done !rule_total)
+      message = Some (Pp.verbatim
+                        (sprintf "Done: %u/%u" !rule_done !rule_total))
     ; show_jobs = true
     }
   in