1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
module String = CString
type t = string
(** We use the concatenated string, with dots separating each string. We
forbid the use of dots in the strings. *)
let tags : Terminal.style option String.Map.t ref = ref String.Map.empty
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 style !tags in
name
let repr t = String.split '.' t
let get_style tag =
try String.Map.find tag !tags with Not_found -> assert false
let set_style tag st =
try tags := String.Map.update tag st !tags with Not_found -> assert false
let clear_styles () =
tags := String.Map.map (fun _ -> None) !tags
let dump () = String.Map.bindings !tags
let parse_config s =
let styles = Terminal.parse s in
let set accu (name, st) =
try String.Map.update name (Some st) accu with Not_found -> accu
in
tags := List.fold_left set !tags styles
let tag = Pp.Tag.create "ppstyle"
(** Default tag is to reset everything *)
let default = Terminal.({
fg_color = Some `DEFAULT;
bg_color = Some `DEFAULT;
bold = Some false;
italic = Some false;
underline = Some false;
negative = Some false;
})
let empty = Terminal.make ()
let make_style_stack style_tags =
(** Not thread-safe. We should put a lock somewhere if we print from
different threads. Do we? *)
let style_stack = ref [] in
let peek () = match !style_stack with
| [] -> default (** Anomalous case, but for robustness *)
| st :: _ -> st
in
let push tag =
let style =
try
begin match String.Map.find tag style_tags with
| None -> empty
| Some st -> st
end
with Not_found -> empty
in
(** Use the merging of the latest tag and the one being currently pushed.
This may be useful if for instance the latest tag changes the background and
the current one the foreground, so that the two effects are additioned. *)
let style = Terminal.merge (peek ()) style in
let () = style_stack := style :: !style_stack in
Terminal.eval style
in
let pop _ = match !style_stack with
| [] ->
(** Something went wrong, we fallback *)
Terminal.eval default
| _ :: rem ->
let () = style_stack := rem in
Terminal.eval (peek ())
in
let clear () = style_stack := [] in
push, pop, clear
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 pp_tag t = match Pp.Tag.prj t tag with
| None -> ""
| Some key -> key
let clear_tag_fn = ref (fun () -> ())
let init_color_output () =
let push_tag, pop_tag, clear_tag = make_style_stack !tags in
clear_tag_fn := clear_tag;
let tag_handler = {
Format.mark_open_tag = push_tag;
Format.mark_close_tag = pop_tag;
Format.print_open_tag = ignore;
Format.print_close_tag = ignore;
} in
let open Pp_control in
Format.pp_set_mark_tags !std_ft true;
Format.pp_set_mark_tags !err_ft true;
Format.pp_set_formatter_tag_functions !std_ft tag_handler;
Format.pp_set_formatter_tag_functions !err_ft tag_handler
let color_msg ?loc ?header ft strm =
let pptag = tag in
let open Pp in
let ploc = Option.cata Pp.pr_loc (Pp.mt ()) loc in
let strm = match header with
| None -> hov 0 (ploc ++ strm)
| Some (h, t) ->
let tag = Pp.Tag.inj t pptag in
let h = Pp.tag tag (str h ++ str ":") in
hov 0 (ploc ++ h ++ spc () ++ strm)
in
pp_with ~pp_tag ft strm;
Format.pp_print_newline ft ();
Format.pp_print_flush ft ();
(** In case something went wrong, we reset the stack *)
!clear_tag_fn ()
|
