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
open Lexing
type msg_type = Error | Warning
type during = Usage | Parse | Lex | Eval | Sat | Cnf | Prenex
type loc = Lexing.position * Lexing.position
type msg = msg_type * during * string * loc option
exception TouistFatal of msg
let wrap_width = ref 76
let format = ref "%l:%c: %t: %m"
let loc_format = ref "%l:%c"
let color = ref false
let discard_warnings = ref false
let string_of_type = function
| Warning -> "warning"
| Error -> "error"
let string_of_during = function
| Usage -> "cmd usage"
| Parse -> "parsing"
| Lex -> "lexing"
| Eval -> "evaluation"
| Sat -> "sat solving"
| Cnf -> "cnf transform"
| Prenex -> "prenex transform"
let replace pattern replacement text =
Re_str.(global_replace (regexp pattern) replacement text)
(** [get_loc] translates a 'loc' to an understandable tuple that contains
(num_line, num_col, token_start, token_end). *)
let get_loc loc : int * int * int * int =
let s,e = loc in (s.pos_lnum, (s.pos_cnum - s.pos_bol+1), s.pos_cnum, e.pos_cnum)
let loc_placeholders loc chr =
let s,e = loc in
match chr with
| 'f' -> s.pos_fname
| 'l' -> (string_of_int s.pos_lnum)
| 'c' -> (string_of_int (s.pos_cnum - s.pos_bol+1))
| 'L' -> (string_of_int e.pos_lnum)
| 'C' -> (string_of_int (e.pos_cnum - e.pos_bol+1))
| 'b' -> (string_of_int s.pos_cnum)
| 'B' -> (string_of_int e.pos_cnum)
| c -> "%" ^ Char.escaped c
let all_placeholders loc typ with_colors msg = function
| 'm' -> msg
| 't' -> string_of_type typ
| c -> match loc with None -> "" | Some loc -> loc_placeholders loc c
(** [replace] replaces all '%c' for any character 'c' using the provided
function 'placeholder'. Also replaces all two-characters '\n' to actual
one-character newline.
%t must always be set before %m.
If location isn't available, all text/placeholders before the first
non-location placeholder (as well as any trailing whitespaces) will be
skipped. *)
let replace (placeholder : char -> string) text =
let text = Re_str.global_replace (Re_str.regexp "\\\\n") "\n" text in
let text = Re_str.global_replace (Re_str.regexp "\\\\t") "\t" text in
let rec replace cur_pos =
try
let next_pos = Re_str.search_forward (Re_str.regexp "%[a-zA-Z]") text cur_pos in
String.sub text cur_pos (next_pos-cur_pos)
^ (String.get text (next_pos+1) |> placeholder)
^ if next_pos+2 <= String.length text-1 then replace (next_pos+2) else ""
with Not_found -> String.sub text cur_pos (String.length text - cur_pos)
in replace (if (placeholder 'l')=""
then Re_str.search_forward (Re_str.regexp "%[^flcLCbB]") text 0 else 0)
let string_of_loc ?(fmt=(!loc_format)) (loc:loc) : string =
replace (loc_placeholders loc) fmt
(** Wraps the text at width. Indendation is kept as long no new line is read.
If width = 0, do not wrap. *)
let format_width color width text =
let rec format prev_indent from_pos =
let cur_indent = try (Re_str.search_forward (Re_str.regexp "[^ ]") text from_pos)-from_pos
with Not_found -> 0 in
let wrap_pos =
let newline_pos =
try Re_str.search_forward (Re_str.regexp "\n") text from_pos
with Not_found -> String.length text
in if newline_pos > from_pos+width then from_pos+width else newline_pos
in
let rec spaces = function 0 -> "" | x -> " "^ spaces (x-1) in
match wrap_pos with
| _ when from_pos >= wrap_pos -> ""
| _ when wrap_pos = String.length text ->
spaces prev_indent ^ String.sub text from_pos (wrap_pos-from_pos)
| _ when String.get text wrap_pos = '\n' ->
spaces prev_indent ^ String.sub text from_pos (wrap_pos-from_pos)
^"\n"^ format 0 (wrap_pos+1)
| _ ->
let last_space = try Re_str.search_backward (Re_str.regexp "\\( \\|: \\|, \\|. \\)") text wrap_pos with Not_found -> wrap_pos in
let last_space_end = last_space + if (String.get text last_space)=' ' then 0 else 1 in
spaces prev_indent ^ String.sub text from_pos (last_space_end-from_pos)
^ "\n" ^ format (cur_indent+prev_indent) (last_space_end+1)
in if width != 0 then format 0 0 else text;;
let rec string_of_msg ?(width=(!wrap_width)) ?(color=(!color)) ?(fmt=(!format)) (message:msg) =
let color_backquote text = let colorize str = "\x1b[33m" ^ str ^ "\x1b[0m" in
Re_str.global_substitute (Re_str.regexp "`\\([^`]+\\)`") (fun s -> "`"^ colorize (Re_str.matched_group 1 s) ^"`") text in
let color_quoted text = let colorize str = "\x1b[33m" ^ str ^ "\x1b[0m" in
Re_str.global_substitute (Re_str.regexp "'\\([^']*\\)'") (fun s ->
let s = (Re_str.matched_group 1 s) in
if (String.length s) = 0 then "''" else "'"^ colorize s ^"'") text in
let color_code text = let colorize str = "\x1b[37m" ^ str ^ "\x1b[0m" in
Re_str.global_substitute (Re_str.regexp "^\\( +.*\\)$") (fun s -> colorize (Re_str.matched_group 1 s)) text in
let color_type text = let colorize str = match str with
| "warning" -> "\x1b[33m\x1b[1m" ^str^ "\x1b[0m"
| "error" -> "\x1b[31m\x1b[1m" ^str^ "\x1b[0m"
| str -> str
in Re_str.substitute_first (Re_str.regexp "\\(error\\|warning\\)") (fun s -> colorize (Re_str.matched_group 1 s)) text in
let color_all text = if color then text |> color_code |> color_backquote |> color_quoted |> color_type else text in
let typ,_,text,loc = message in
replace (all_placeholders loc typ color text) fmt |> format_width color width |> color_all
let warn msg = if !discard_warnings then () else Printf.fprintf stderr "%s" (string_of_msg msg)
let fatal msg = raise @@ TouistFatal msg
let _ = Printexc.register_printer (fun ex -> match ex with TouistFatal msg -> Some (string_of_msg msg) | _ -> None)