From 03f788a0fa7a5b732618f6c1d4863308307d16c1 Mon Sep 17 00:00:00 2001
From: Jeremie Dimino <jdimino@janestreet.com>
Date: Fri, 24 Feb 2017 11:16:55 +0000
Subject: [PATCH] a bit more colors

---
 bin/main.ml         |  1 +
 src/ansi_color.ml   | 24 ++++++++++++++++++++++++
 src/ansi_color.mli  |  7 +++++++
 src/future.ml       | 16 +++++-----------
 src/jbuild_types.ml |  4 +---
 src/main.ml         |  4 ++--
 6 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/bin/main.ml b/bin/main.ml
index 35955963..1fa26e2d 100644
--- a/bin/main.ml
+++ b/bin/main.ml
@@ -200,5 +200,6 @@ let () =
     | `Error _ -> exit 1
     | _ -> exit 0
   with exn ->
+    Ansi_color.setup_err_formatter_colors ();
     Format.eprintf "%a@?" (Main.report_error ?map_fname:None) exn;
     exit 1
diff --git a/src/ansi_color.ml b/src/ansi_color.ml
index 9b6c9cb7..ec8a0e00 100644
--- a/src/ansi_color.ml
+++ b/src/ansi_color.ml
@@ -117,6 +117,12 @@ let stderr_supports_colors = lazy(
   | _ -> true
 )
 
+let strip_colors_for_stderr s =
+  if Lazy.force stderr_supports_colors then
+    s
+  else
+    strip s
+
 (* We redirect the output of all commands, so by default the compiler will disable
    colors. Since we support colors in the output of commands, we force it via OCAMLPARAM
    if stderr supports colors. *)
@@ -131,3 +137,21 @@ let setup_env_for_ocaml_colors = lazy(
   end
 )
 
+let setup_err_formatter_colors () =
+  let open Format in
+  if Lazy.force stderr_supports_colors then begin
+    let ppf = err_formatter in
+    let funcs = pp_get_formatter_tag_functions ppf () in
+    pp_set_mark_tags ppf true;
+    pp_set_formatter_tag_functions ppf
+      { funcs with
+        mark_close_tag = (fun _ -> ansi_escape_of_styles [Reset])
+      ; mark_open_tag = (fun tag ->
+        ansi_escape_of_styles
+          (match tag with
+           | "loc" -> [Bold]
+           | "error" -> [Bold; Foreground Red]
+           | "warning" -> [Bold; Foreground Magenta]
+           | _ -> []))
+      }
+  end
diff --git a/src/ansi_color.mli b/src/ansi_color.mli
index e895ecc3..14d5d8dd 100644
--- a/src/ansi_color.mli
+++ b/src/ansi_color.mli
@@ -2,3 +2,10 @@ val colorize : key:string -> string -> string
 val strip : string -> string
 val stderr_supports_colors : bool Lazy.t
 val setup_env_for_ocaml_colors : unit Lazy.t
+
+(** Strip colors in [not (Lazy.force stderr_supports_colors)] *)
+val strip_colors_for_stderr : string -> string
+
+(** Enable the interpretation of ["loc"], ["error"] and ["warning"] tags for
+    [Format.err_formatter] *)
+val setup_err_formatter_colors : unit -> unit
diff --git a/src/future.ml b/src/future.ml
index 8bfefb30..4a8d185b 100644
--- a/src/future.ml
+++ b/src/future.ml
@@ -223,12 +223,6 @@ module Scheduler = struct
     | _ -> true
   )
 
-  let strip_colors_for_stderr s =
-    if Lazy.force Ansi_color.stderr_supports_colors then
-      s
-    else
-      Ansi_color.strip s
-
   type running_job =
     { id              : int
     ; job             : job
@@ -279,14 +273,14 @@ module Scheduler = struct
       | WEXITED n ->
         Printf.eprintf "\nCommand [%d] exited with code %d:\n$ %s\n%s%!"
           job.id n
-          (strip_colors_for_stderr job.command_line)
-          (strip_colors_for_stderr output);
+          (Ansi_color.strip_colors_for_stderr job.command_line)
+          (Ansi_color.strip_colors_for_stderr output);
         die ""
       | WSIGNALED n ->
         Printf.eprintf "\nCommand [%d] got signal %d:\n$ %s\n%s%!"
           job.id n
-          (strip_colors_for_stderr job.command_line)
-          (strip_colors_for_stderr output);
+          (Ansi_color.strip_colors_for_stderr job.command_line)
+          (Ansi_color.strip_colors_for_stderr output);
         die ""
       | WSTOPPED _ -> assert false
     end
@@ -332,7 +326,7 @@ module Scheduler = struct
         let command_line = command_line job in
         if !Clflags.debug_run then
           Printf.eprintf "Running[%d]: %s\n%!" id
-            (strip_colors_for_stderr command_line);
+            (Ansi_color.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
diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml
index 4048dbc8..784bf29c 100644
--- a/src/jbuild_types.ml
+++ b/src/jbuild_types.ml
@@ -813,9 +813,7 @@ module Stanza = struct
 
   let resolve_packages ts ~dir ~visible_packages =
     let error fmt =
-      die ("File \"%s\", line 1, characters 0-0:\n\
-            Error: " ^^ fmt)
-        (Path.to_string (Path.relative dir "jbuild"))
+      Loc.fail (Loc.in_file (Path.to_string (Path.relative dir "jbuild"))) fmt
     in
     let known_packages () =
       let visible_packages = String_map.bindings visible_packages in
diff --git a/src/main.ml b/src/main.ml
index 89bab800..abc3e694 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -49,8 +49,8 @@ let report_error ?(map_fname=fun x->x) ppf exn ~backtrace =
     let start_c = start.pos_cnum - start.pos_bol in
     let stop_c  = stop.pos_cnum  - start.pos_bol in
     Format.fprintf ppf
-      "File \"%s\", line %d, characters %d-%d:\n\
-       Error: %s\n"
+      "@{<loc>File \"%s\", line %d, characters %d-%d:@}\n\
+       @{<error>Error@}: %s\n"
       (map_fname start.pos_fname) start.pos_lnum start_c stop_c msg
   | Fatal_error "" -> ()
   | Fatal_error msg ->