blob: 55b07ed464088011d4a34c3a49ee1bf0de474d79 (
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
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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
module H = Easy_logging.Handlers
module L = Easy_logging.Logging
let _ = L.make_logger "MainLogger" Debug [ Cli Debug ]
(** The main logger *)
let main_log = L.get_logger "MainLogger"
(** Below, we create subgloggers for various submodules, so that we can precisely
toggle logging on/off, depending on which information we need *)
(** Logger for PrePasses *)
let pre_passes_log = L.get_logger "MainLogger.PrePasses"
(** Logger for Translate *)
let translate_log = L.get_logger "MainLogger.Translate"
(** Logger for PureUtils *)
let pure_utils_log = L.get_logger "MainLogger.PureUtils"
(** Logger for SymbolicToPure *)
let symbolic_to_pure_log = L.get_logger "MainLogger.SymbolicToPure"
(** Logger for PureMicroPasses *)
let pure_micro_passes_log = L.get_logger "MainLogger.PureMicroPasses"
(** Logger for PureToExtract *)
let pure_to_extract_log = L.get_logger "MainLogger.PureToExtract"
(** Logger for Interpreter *)
let interpreter_log = L.get_logger "MainLogger.Interpreter"
(** Logger for InterpreterStatements *)
let statements_log = L.get_logger "MainLogger.Interpreter.Statements"
(** Logger for InterpreterExpressions *)
let expressions_log = L.get_logger "MainLogger.Interpreter.Expressions"
(** Logger for InterpreterPaths *)
let paths_log = L.get_logger "MainLogger.Interpreter.Paths"
(** Logger for InterpreterExpansion *)
let expansion_log = L.get_logger "MainLogger.Interpreter.Expansion"
(** Logger for InterpreterBorrows *)
let borrows_log = L.get_logger "MainLogger.Interpreter.Borrows"
(** Logger for Invariants *)
let invariants_log = L.get_logger "MainLogger.Interpreter.Invariants"
(** Terminal colors - TODO: comes from easy_logging (did not manage to reuse the module directly) *)
type color =
| Default
| Black
| Red
| Green
| Yellow
| Blue
| Magenta
| Cyan
| Gray
| White
| LRed
| LGreen
| LYellow
| LBlue
| LMagenta
| LCyan
| LGray
(** Terminal styles - TODO: comes from easy_logging (did not manage to reuse the module directly) *)
type format = Bold | Underline | Invert | Fg of color | Bg of color
(** TODO: comes from easy_logging (did not manage to reuse the module directly) *)
let to_fg_code c =
match c with
| Default -> 39
| Black -> 30
| Red -> 31
| Green -> 32
| Yellow -> 33
| Blue -> 34
| Magenta -> 35
| Cyan -> 36
| Gray -> 90
| White -> 97
| LRed -> 91
| LGreen -> 92
| LYellow -> 93
| LBlue -> 94
| LMagenta -> 95
| LCyan -> 96
| LGray -> 37
(** TODO: comes from easy_logging (did not manage to reuse the module directly) *)
let to_bg_code c =
match c with
| Default -> 49
| Black -> 40
| Red -> 41
| Green -> 42
| Yellow -> 43
| Blue -> 44
| Magenta -> 45
| Cyan -> 46
| Gray -> 100
| White -> 107
| LRed -> 101
| LGreen -> 102
| LYellow -> 103
| LBlue -> 104
| LMagenta -> 105
| LCyan -> 106
| LGray -> 47
(** TODO: comes from easy_logging (did not manage to reuse the module directly) *)
let style_to_codes s =
match s with
| Bold -> (1, 21)
| Underline -> (4, 24)
| Invert -> (7, 27)
| Fg c -> (to_fg_code c, to_fg_code Default)
| Bg c -> (to_bg_code c, to_bg_code Default)
(** TODO: comes from easy_logging (did not manage to reuse the module directly) *)
let level_to_color (lvl : L.level) =
match lvl with
| L.Flash -> LMagenta
| Error -> LRed
| Warning -> LYellow
| Info -> LBlue
| Trace -> Cyan
| Debug -> Green
| NoLevel -> Default
(** [format styles str] formats [str] to the given [styles] -
TODO: comes from easy_logging (did not manage to reuse the module directl)
*)
let rec format styles str =
match styles with
| (_ as s) :: styles' ->
let set, reset = style_to_codes s in
Printf.sprintf "\027[%dm%s\027[%dm" set (format styles' str) reset
| [] -> str
(** TODO: comes from easy_logging (did not manage to reuse the module directly) *)
let format_tags (tags : string list) =
match tags with
| [] -> ""
| _ ->
let elems_str = String.concat " | " tags in
"[" ^ elems_str ^ "] "
(* Change the formatters *)
let main_logger_handler =
(* TODO: comes from easy_logging *)
let formatter (item : L.log_item) : string =
let item_level_fmt =
format [ Fg (level_to_color item.level) ] (L.show_level item.level)
and item_msg_fmt =
match item.level with
| Flash -> format [ Fg Black; Bg LMagenta ] item.msg
| _ -> item.msg
in
Format.pp_set_max_indent Format.str_formatter 200;
Format.sprintf "@[[%-15s] %s%s@]" item_level_fmt (format_tags item.tags)
item_msg_fmt
in
(* There should be exactly one handler *)
let handlers = main_log#get_handlers in
List.iter (fun h -> H.set_formatter h formatter) handlers;
match handlers with [ handler ] -> handler | _ -> failwith "Unexpected"
|
