blob: aa47c51671b8c4d9bc37715046ab9aab272c0a99 (
plain)
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
|
(************************************************************************)
(* 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 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
|
