Source file `debug.ml`

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
(****************************************************************************)
(*                                                                          *)
(* This file is part of MOPSA, a Modular Open Platform for Static Analysis. *)
(*                                                                          *)
(* Copyright (C) 2017-2019 The MOPSA Project.                               *)
(*                                                                          *)
(* This program is free software: you can redistribute it and/or modify     *)
(* it under the terms of the GNU Lesser General Public License as published *)
(* by the Free Software Foundation, either version 3 of the License, or     *)
(* (at your option) any later version.                                      *)
(*                                                                          *)
(* This program is distributed in the hope that it will be useful,          *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of           *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            *)
(* GNU Lesser General Public License for more details.                      *)
(*                                                                          *)
(* You should have received a copy of the GNU Lesser General Public License *)
(* along with this program.  If not, see <http://www.gnu.org/licenses/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Debug - Conditional debugging with channel filtering. *)

let channels = ref []
let print_warnings = ref true
let print_color = ref true
let print_all = ref false
let white = 1
let red = 9
let green = 0x28
let yellow = 0xbe
let blue = 12
let magenta = 5
let fushia = 177
let orange = 0xd0
let teal = 6
let gray = 8
let pink = 162

let add_channel ch =
  if ch = "all" then
    print_all := true
  else
    let ch' = ch ^ "$" |>
              Str.global_replace (Str.regexp_string ".") "\\."  |>
              Str.global_replace (Str.regexp_string "_") ".*"
    in
    let re = Str.regexp ch' in
    channels := re :: !channels


(* Parse a list of channels separated by ',' *)
let parse opt =
  Str.split (Str.regexp ",") opt |>
  List.iter add_channel

let set_channels opt =
  let () = channels := [] in
  parse opt

let can_print channel =
  !print_all ||
  !channels |> List.exists (fun re -> Str.string_match re channel 0)

(** Gives a random map of channel colors *)
let random_color channel =
  (Hashtbl.hash channel mod 26) * 9 + 2

let color code pp fmt x =
  if !print_color then
    Format.fprintf fmt "\027[1;38;5;%dm%a\027[0m" code pp x
  else
    Format.fprintf fmt "%a" pp x

let color_str c fmt s = color c Format.pp_print_string fmt s

let bold pp fmt x =
  if !print_color then
    Format.fprintf fmt "\027[1m%a\027[0m" pp x
  else
    Format.fprintf fmt "%a" pp x

let pp_channel fmt channel =
  if !print_color then
    Format.fprintf fmt "\027[1;38;5;%dm%s\027[0m" (random_color channel) channel
  else
    Format.pp_print_string fmt channel


let pp_channel_with_time fmt channel =
  if !print_color then
    Format.printf "\027[1;38;5;%dm[%s %.3f]\027[0m" (random_color channel) channel (Sys.time ())
  else
    Format.printf "[%s %.3f]" channel (Sys.time ())

let debug ?(channel = "debug") fmt =
  if can_print channel then
    Format.kasprintf (fun str ->
        Format.printf "%a @[%s@]@." pp_channel_with_time channel str
      ) fmt
  else
    Format.ifprintf Format.std_formatter fmt


let info fmt =
    if can_print "info" then
      Format.kasprintf (fun str ->
          Format.printf "[%a] %s@." (color_str orange) "*" str
      ) fmt
  else
    Format.ifprintf Format.std_formatter fmt

let plurial_list fmt l = if List.length l <= 1 then () else Format.pp_print_string fmt "s"
let plurial_int fmt n = if n <= 1 then () else Format.pp_print_string fmt "s"

let panic fmt =
  Format.kasprintf (fun str ->
        Format.printf "%a: %s@." (color_str red) "panic" str
      ) fmt

let panic_at range fmt =
  Format.kasprintf (fun str ->
      Format.printf "%a: panic: %s@." (color red Location.pp_range) range str
    ) fmt


let warn fmt =
  if !print_warnings then
    Format.kasprintf (fun str ->
        Format.eprintf "%a: %s@." (color_str orange) "warning" str
      ) fmt
  else
    Format.ifprintf Format.err_formatter fmt


let warn_at range fmt =
    if !print_warnings then
      Format.kasprintf (fun str ->
          Format.eprintf "%a: warning: %s@." (color orange Location.pp_range) range str
        ) fmt
    else
      Format.ifprintf Format.err_formatter fmt



(* simple detection of terminal coloring capabilities, using TERM variable;
   able to detect whether we are runnig under emacs and force no-color
 *)
let terminal_has_colors () =
  try match Sys.getenv "TERM" with
      | "dumb" | "" -> false
      | _ -> true (* by default *)
  with Not_found -> false

let () = print_color := terminal_has_colors ()