This repository has been archived by the owner on Nov 30, 2020. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 25
/
location.ml
299 lines (252 loc) Β· 8.59 KB
/
location.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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
open Lexing
open Core.Std
let absname = ref false
(* This reference should be in Clflags, but it would create an additional
dependency and make bootstrapping Camlp4 more difficult. *)
type t = { loc_start: position; loc_end: position; loc_ghost: bool };;
let in_file name =
let loc = {
pos_fname = name;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = -1;
} in
{ loc_start = loc; loc_end = loc; loc_ghost = true }
;;
let none = in_file "_none_";;
let curr lexbuf = {
loc_start = lexbuf.lex_start_p;
loc_end = lexbuf.lex_curr_p;
loc_ghost = false
};;
let init lexbuf fname =
lexbuf.lex_curr_p <- {
pos_fname = fname;
pos_lnum = 1;
pos_bol = 0;
pos_cnum = 0;
}
;;
let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)
let num_loc_lines = ref 0 (* number of lines already printed after input *)
open Textutils.Std
let highlight_textutils ppf lb loc =
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
(* Do nothing if the buffer does not contain the whole phrase. *)
if pos0 < 0 then raise Exit;
let end_pos = lb.lex_buffer_len - pos0 - 1 in
(* Determine line numbers for the start and end points *)
let line_start = ref 0 and line_end = ref 0 in
for pos = 0 to end_pos do
if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
if loc.loc_start.pos_cnum > pos then incr line_start;
if loc.loc_end.pos_cnum > pos then incr line_end;
end
done;
(* Print character location (useful for Emacs) *)
Format.fprintf ppf "Characters %i-%i:@."
loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
Console.Ansi.printf [`Bright] "%s:%d:%d\n" lb.lex_curr_p.pos_fname lb.lex_curr_p.pos_lnum
lb.lex_curr_p.pos_cnum
(* Highlight the location by printing it again. *)
let highlight_dumb ppf lb loc =
(* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
let pos0 = -lb.lex_abs_pos in
(* Do nothing if the buffer does not contain the whole phrase. *)
if pos0 < 0 then raise Exit;
let end_pos = lb.lex_buffer_len - pos0 - 1 in
(* Determine line numbers for the start and end points *)
let line_start = ref 0 and line_end = ref 0 in
for pos = 0 to end_pos do
if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin
if loc.loc_start.pos_cnum > pos then incr line_start;
if loc.loc_end.pos_cnum > pos then incr line_end;
end
done;
(* Print character location (useful for Emacs) *)
Format.fprintf ppf "Characters %i-%i:@."
loc.loc_start.pos_cnum loc.loc_end.pos_cnum;
(* Print the input, underlining the location *)
Format.pp_print_string ppf " ";
let line = ref 0 in
let pos_at_bol = ref 0 in
for pos = 0 to end_pos do
match Bytes.get lb.lex_buffer (pos + pos0) with
| '\n' ->
if !line = !line_start && !line = !line_end then begin
(* loc is on one line: underline location *)
Format.fprintf ppf "@. ";
for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do
Format.pp_print_char ppf ' '
done;
for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do
Format.pp_print_char ppf '^'
done
end;
if !line >= !line_start && !line <= !line_end then begin
Format.fprintf ppf "@.";
if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " "
end;
incr line;
pos_at_bol := pos + 1
| '\r' -> () (* discard *)
| c ->
if !line = !line_start && !line = !line_end then
(* loc is on one line: print whole line *)
Format.pp_print_char ppf c
else if !line = !line_start then
(* first line of multiline loc:
print a dot for each char before loc_start *)
if pos < loc.loc_start.pos_cnum then
Format.pp_print_char ppf '.'
else
Format.pp_print_char ppf c
else if !line = !line_end then
(* last line of multiline loc: print a dot for each char
after loc_end, even whitespaces *)
if pos < loc.loc_end.pos_cnum then
Format.pp_print_char ppf c
else
Format.pp_print_char ppf '.'
else if !line > !line_start && !line < !line_end then
(* intermediate line of multiline loc: print whole line *)
Format.pp_print_char ppf c
done
(* Highlight the location using one of the supported modes. *)
let rec highlight_locations ppf locs =
match !input_lexbuf with
| None -> false
| Some lb -> begin
print_endline "Terminfo Bad_term";
let norepeat = (Sys.getenv "TERM") = (Some "norepeat") in
if norepeat then false else
let loc1 = List.hd_exn locs in
try highlight_dumb ppf lb loc1; true
with Exit -> false
end
(* Print the location in some way or another *)
open Format
let absolute_path s = (* This function could go into Filename *)
let open Filename in
let s = if is_relative s then concat (Sys.getcwd ()) s else s in
(* Now simplify . and .. components *)
let rec aux s =
let base = basename s in
let dir = dirname s in
if dir = s then dir
else if base = current_dir_name then aux dir
else if base = parent_dir_name then dirname (aux dir)
else concat (aux dir) base
in
aux s
let show_filename file =
if !absname then absolute_path file else file
let print_filename ppf file =
Format.fprintf ppf "%s" (show_filename file)
let reset () =
num_loc_lines := 0
let (msg_file, msg_line, msg_chars, msg_to, msg_colon) =
("File \"", "\", line ", ", characters ", "-", ":")
(* return file, line, char from the given position *)
let get_pos_info pos =
(pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol)
;;
let print_loc ppf loc =
let (file, line, startchar) = get_pos_info loc.loc_start in
let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in
if file = "//toplevel//" then begin
if highlight_locations ppf [loc] then () else
fprintf ppf "Characters %i-%i"
loc.loc_start.pos_cnum loc.loc_end.pos_cnum
end else begin
fprintf ppf "%s%a%s%i" msg_file print_filename file msg_line line;
if startchar >= 0 then
fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar
end
;;
let print ppf loc =
if loc.loc_start.pos_fname = "//toplevel//"
&& highlight_locations ppf [loc] then ()
else fprintf ppf "%a%s@." print_loc loc msg_colon
;;
let print_error ppf loc =
print ppf loc;
fprintf ppf "Error: ";
;;
let print_error_cur_file ppf = print_error ppf (in_file !input_name);;
let echo_eof () =
print_newline ();
incr num_loc_lines
type 'a loc = {
txt : 'a;
loc : t;
}
let mkloc txt loc = { txt ; loc }
let mknoloc txt = mkloc txt none
type error =
{
loc: t;
msg: string;
sub: error list;
if_highlight: string; (* alternative message if locations are highlighted *)
}
let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
Printf.ksprintf (fun msg -> {loc; msg; sub; if_highlight})
let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg =
{loc; msg; sub; if_highlight}
let error_of_exn : (exn -> error option) list ref = ref []
let register_error_of_exn f = error_of_exn := f :: !error_of_exn
let error_of_exn exn =
let rec loop = function
| [] -> None
| f :: rest ->
match f exn with
| Some _ as r -> r
| None -> loop rest
in
loop !error_of_exn
let rec report_error ppf ({loc; msg; sub; if_highlight} as err) =
let highlighted =
if if_highlight <> "" then
let rec collect_locs locs {loc; sub; if_highlight; _} =
List.fold_left ~f:collect_locs ~init:(loc :: locs) sub
in
let locs = collect_locs [] err in
highlight_locations ppf locs
else
false
in
if highlighted then
Format.pp_print_string ppf if_highlight
else begin
print ppf loc;
Format.pp_print_string ppf msg;
List.iter sub ~f:(fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err)
end
let error_of_printer loc print x =
let buf = Buffer.create 64 in
let ppf = Format.formatter_of_buffer buf in
pp_print_string ppf "Error: ";
print ppf x;
pp_print_flush ppf ();
let msg = Buffer.contents buf in
errorf ~loc "%s" msg
let error_of_printer_file print x =
error_of_printer (in_file !input_name) print x
let () =
register_error_of_exn
(function
| Sys_error msg ->
Some (errorf ~loc:(in_file !input_name) "Error: I/O error: %s" msg)
| _ -> None
)
let report_exception ppf exn =
match error_of_exn exn with
| Some err -> fprintf ppf "@[%a@]@." report_error err
| None -> raise exn
exception Error of error
let () =
register_error_of_exn (function Error e -> Some e
| _ -> None)