Default styles for printing tags.

They should be rather sensible, but de gustibus & coloribus...

3 files changed, 27 insertions, 10 deletions

diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml
index fd4676530..69fc30864 100644
--- a/printing/ppconstr.ml
+++ b/printing/ppconstr.ml
@@ -811,9 +811,17 @@ end
 
 module Tag =
 struct
-  let keyword = Ppstyle.make ["constr"; "keyword"]
-  let evar = Ppstyle.make ["constr"; "evar"]
-  let univ = Ppstyle.make ["constr"; "type"]
+  let keyword =
+    let style = Terminal.make ~bold:true () in
+    Ppstyle.make ~style ["constr"; "keyword"]
+
+  let evar =
+    let style = Terminal.make ~bold:true ~fg_color:`BLUE () in
+    Ppstyle.make ~style ["constr"; "evar"]
+
+  let univ =
+    let style = Terminal.make ~bold:true ~fg_color:`YELLOW () in
+    Ppstyle.make ~style ["constr"; "type"]
 end
 
 let do_not_tag _ x = x
diff --git a/printing/ppstyle.ml b/printing/ppstyle.ml
index d001c2eb0..9839b627b 100644
--- a/printing/ppstyle.ml
+++ b/printing/ppstyle.ml
@@ -14,12 +14,12 @@ type t = string
 
 let tags : Terminal.style option String.Map.t ref = ref String.Map.empty
 
-let make tag =
+let make ?style tag =
   let check s = if String.contains s '.' then invalid_arg "Ppstyle.make" in
   let () = List.iter check tag in
   let name = String.concat "." tag in
   let () = assert (not (String.Map.mem name !tags)) in
-  let () = tags := String.Map.add name None !tags in
+  let () = tags := String.Map.add name style !tags in
   name
 
 let repr t = String.split '.' t
@@ -91,9 +91,17 @@ let make_style_stack style_tags =
   let clear () = style_stack := [] in
   push, pop, clear
 
-let error_tag = make ["message"; "error"]
-let warning_tag = make ["message"; "warning"]
-let debug_tag = make ["message"; "debug"]
+let error_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in
+  make ~style ["message"; "error"]
+
+let warning_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`YELLOW () in
+  make ~style ["message"; "warning"]
+
+let debug_tag =
+  let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`MAGENTA () in
+  make ~style ["message"; "debug"]
 
 let init_color_output () =
   let push_tag, pop_tag, clear_tag = make_style_stack !tags in
diff --git a/printing/ppstyle.mli b/printing/ppstyle.mli
index 700ec4314..e6e664f79 100644
--- a/printing/ppstyle.mli
+++ b/printing/ppstyle.mli
@@ -14,8 +14,9 @@
 type t
 (** Style tags *)
 
-val make : string list -> t
-(** Create a new tag with the given name. Each name must be unique. *)
+val make : ?style:Terminal.style -> string list -> t
+(** Create a new tag with the given name. Each name must be unique. The optional
+    style is taken as the default one. *)
 
 val repr : t -> string list
 (** Gives back the original name of the style tag where each string has been