-
Notifications
You must be signed in to change notification settings - Fork 125
/
filePos.ml
536 lines (451 loc) · 16.4 KB
/
filePos.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
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA 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 Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF MLI *)
module Format = BaseFormat
module List = BaseList
(* alias type *)
type filename = string
type content = string
type absolute_char_offset = int
type line_number = int
type column_number = int
(* cache mechanisme *)
(* memoize filename,content,offsetmap (first line char -> line)
globally to retrieve easily information from file on errors *)
let parsed_files : (string, (string * int IntMap.t)) Hashtbl.t = Hashtbl.create 16
(* an other cache for having the reverse map *)
let reverse_parsed_files : (string, int array) Hashtbl.t = Hashtbl.create 16
let debug () =
let iter file (_content, map) =
Printf.printf "File %S\n" file;
IntMap.iter (fun offset line -> Printf.printf "line %d -- global offset %d\n%!" line offset) map
in
Hashtbl.iter iter parsed_files
let get_file_content file =
fst (Hashtbl.find parsed_files file)
let uncache file =
Hashtbl.remove parsed_files file;
Hashtbl.remove reverse_parsed_files file
let clear () =
Hashtbl.clear parsed_files;
Hashtbl.clear reverse_parsed_files
(* compute maps of previous structure *)
let rec compute_lines content pos line map =
let len = String.length content in
if pos < len then
if
content.[pos] = '\n' ||
content.[pos] = '\r' && ( ( (pos<len-1) && content.[pos+1]<>'\n' ) ||
( (pos>1 ) && content.[pos-1]<>'\n' ) )
then
compute_lines content (pos+1) (line+1) (IntMap.add (pos+1) (line+1) map)
else compute_lines content (pos+1) line map
else map
(* add a file to the memoization *)
let add_file file content =
let pos_line_map = compute_lines content 0 1 (IntMap.add 0 1 IntMap.empty) in
Hashtbl.replace parsed_files file (content, pos_line_map)
(* get the line and column number from a char position for a given file *)
let get_line_char file i =
let i = max 0 i in
let get_line_char map i =
let i_line, line_number = try IntMap.find_inf i map with Not_found -> (1,1) in
let char_in_line = i - i_line in
(line_number, char_in_line)
in
let _, map = Hashtbl.find parsed_files file in
get_line_char map i
let get_pos filename offset =
let getLine = get_line_char filename in
getLine offset
let get_pos_string (line, column) =
Printf.sprintf "line %d, column %d" line column
let get_line filename offset =
let offset = max 0 offset in
let line, col = get_pos filename offset in
(* Printf.fprintf stdout "get_line %d -> %d (line %d)\n%!" offset (offset - col) line; *)
offset-col, line
let get_next_line file i =
let default = (1, 1) in
try (
let _, map = Hashtbl.find parsed_files file in
try
IntMap.find_sup i map
with Not_found -> (
try IntMap.find_inf i map
with Not_found -> default
)
) with Not_found -> default
let cache_reverse_map file array =
Hashtbl.add reverse_parsed_files file array
let build_reverse_map map =
let size = IntMap.size map in
let t = Array.make size 0 in
IntMap.iter (fun i j -> t.(pred j) <- i) map;
t
let line_position file line =
let lines =
try
Hashtbl.find reverse_parsed_files file
with
| Not_found ->
(* this can also raise Not_found *)
let _, map = Hashtbl.find parsed_files file in
let array = build_reverse_map map in
cache_reverse_map file array;
array
in
let len = Array.length lines in
if (1 <= line) && (line <= len)
then
let start = lines.(line-1) in
if line < len
then start, lines.(line)
else start, start
else raise Not_found
(* position tracking *)
type range = {
start : absolute_char_offset ;
stop : absolute_char_offset ;
}
type filerange = {
filename : filename ;
ranges : range HdList.t
}
type private_cache = {
mutable one_loc : (filename * line_number) option ;
}
type pos =
| Builtin of string
| Files of filerange HdList.t * private_cache
let make_cache () = {
one_loc = None ;
}
let nopos pass = Builtin pass
let get_file = function
| Builtin pass -> Printf.sprintf "builtin_%s" pass
| Files (hd, _) -> (HdList.hd hd).filename
let get_one_loc = function
| Builtin pass -> Printf.sprintf "builtin_%s" pass, 0
| Files (hd, cache) -> (
match cache.one_loc with
| Some loc -> loc
| None ->
let hd = HdList.hd hd in
let filename = hd.filename in
let start = (HdList.hd hd.ranges).start in
let _, line = get_line filename start in
let loc = filename, line in
cache.one_loc <- Some loc ;
loc
)
let get_first_char = function
| Builtin _ -> 0
| Files ((f, _), _) -> (fst f.ranges).start
let make_pos filename start stop =
if stop < start then invalid_arg "FilePos.make_pos" else
let range = { start = start ; stop = stop } in
Files (
(HdList.singleton { filename = filename ; ranges = HdList.singleton range } ),
make_cache ()
)
let cmp (a, _) (b, _) = compare a b
let sort_pos = List.sort cmp
let make_pos_from_line file line =
try
let start, stop = line_position file line in
let pos = make_pos file start stop in
let () =
match pos with
| Files (_, cache) -> cache.one_loc <- Some (file, line)
| _ -> ()
in
pos
with
| Not_found ->
nopos (Printf.sprintf "File %S, line %d:" file line)
let merge_range {start = x1; stop = y1} {start = x2; stop = y2} =
{start = min x1 x2; stop = max y1 y2}
let merge_pos_for_parser p1 p2 =
match p1, p2 with
| Files (({filename=filename1;ranges=(range1,[])},[]), _),
Files (({filename=filename2;ranges=(range2,[])},[]), _) ->
assert (filename1 = filename2);
Files (
({filename=filename1; ranges = (merge_range range1 range2, [])}, []),
make_cache()
)
| _ -> assert false
(* very bad complexity, but in practice the list are very little (less than 20 files) *)
module LH = ListHashtbl
let merge_pos p1 p2 =
match p1, p2 with
| Builtin _, a | a, Builtin _ -> a
| Files (r, _), Files (r', _) -> (
let lh = LH.create 10 in
(* collect by filenames *)
let iter f =
let filename = f.filename in
HdList.iter (fun r -> LH.add lh filename (r.start, r.stop)) f.ranges in
HdList.iter iter r ;
HdList.iter iter r';
(* insertion of a segment in a segment list sorted by start *)
let rec merge acc ((start, stop) as seg) =
match acc with
| [] -> [ seg ]
| ((start', stop') as hd)::tl ->
if start > stop' + 1 then hd::(merge tl seg)
else
if stop < start' - 1 then seg::acc
else
(min start start', max stop stop')::tl
in
let collect filename segs acc =
let segs = List.fold_left merge [] segs in
let ranges = List.fold_left (fun acc (start, stop) -> { start = start ; stop = stop } :: acc ) [] segs in
{ filename = filename ; ranges = HdList.wrap (List.rev ranges) } :: acc
in
let ranges = List.rev (LH.fold_list collect lh []) in
Files ((HdList.wrap ranges), make_cache())
)
let merge_pos_list = function
| [] -> invalid_arg "FilePos.merge_pos_list"
| h :: t -> List.fold_left merge_pos h t
let is_empty = function
| Builtin _ -> true
| _ -> false
let to_string_range filename r =
let start = r.start in
let stop = r.stop in
try
let line1, col1 = get_pos filename start in
let line2, col2 = get_pos filename stop in
(* Do not change the layout there, or update in the opa-mode the variable compilation-error-regexp-alist *)
Printf.sprintf "File %S, line %d, characters %d-%d, (%d:%d-%d:%d | %d-%d)" filename line1 col1 (col1 + stop - start) line1 col1 line2 col2
(#<If:TESTING> 0 #<Else> start #<End>)
(#<If:TESTING> 0 #<Else> stop #<End>)
with
| Not_found ->
Printf.sprintf "File %S (%d-%d)" filename start stop
let pp_filerange filename fmt r =
Format.pp_print_string fmt (to_string_range filename r)
let pp_filerange fmt {filename=filename; ranges=ranges} =
let ranges = HdList.unwrap ranges in
Format.pp_list "@\n" (pp_filerange filename) fmt ranges
let pp_pos fmt = function
| Builtin pass -> Format.fprintf fmt "<no position available (%s)>" pass
| Files (files, _) ->
let files = HdList.unwrap files in
Format.pp_list "@\n" pp_filerange fmt files
let pp_files fmt = function
| Builtin pass -> Format.fprintf fmt "<no file available (%s)>" pass
| Files (files, _) ->
let files = HdList.unwrap files in
Format.pp_list ", " (fun fmt v -> Format.pp_print_string fmt v.filename) fmt files
let to_string_filerange f = Format.to_string pp_filerange f
let to_string p = Format.to_string pp_pos p
(* deprecated API *)
let to_old_pos_many = function
| Builtin _ -> StringMap.empty
| Files (fileranges, _) ->
let translate {start = d; stop = f} = (d, f) in
let fold map f =
let file = f.filename in
let r, ranges = f.ranges in
let wrong = List.fold_left merge_range r ranges in
StringMap.add file (translate wrong) map
in
HdList.fold_left fold StringMap.empty fileranges
let to_old_pos nopos = function
| Builtin _ -> nopos ()
| Files ((f, _), _) ->
let r = fst f.ranges in
f.filename, r.start, r.stop
(* citations *)
(*
The effeciency is not a goal, because we are just printing once a citation in case
of error. So, do not hack the code for unused optimisation, keep it rather simple.
*)
type options = {
truncate_lines : int option ;
lines_before : int ;
lines_after : int ;
lines_between : int ;
color : Ansi.color option ;
max_length_citation : int option ;
}
let default_options = {
truncate_lines = Some 80 ;
lines_before = 5 ;
lines_after = 5 ;
lines_between = 5 ;
color = Some ( `red : Ansi.color ) ;
max_length_citation = Some 200 ;
}
(* Shame : no Format.pp_print_string_sub ? *)
let pp_print_string_sub fmt content offset len = Format.pp_print_string fmt (String.sub content offset len)
let no_citation fmt pass =
Format.fprintf fmt "%s (no-citation-available)@\n" pass
(* ALL THE FOLLOWING FUNCTIONS MAY RAISE NOT_FOUND, BUT THEY ARE ALL USED ONLY
INTERNALLY BY THE FUNCTION CITATION, WHICH CATCH THE EXCEPTION.
*)
(* this function return the global offset of the first char of the previous line of the line which contains the char offset *)
(*
called with the offset of m :
p
m
it returns the offset of p
*)
let predline_offset filename offset =
let offset, _ = get_line filename offset in
let offset, _ = get_line filename (pred offset) in
offset
(* symetric *)
let succline_offset filename offset =
let offset, _ = get_next_line filename (succ offset) in
offset
(* compose predline or succ line, return the sorted offset of successive lines *)
let compose n line_offset filename offset =
let rec aux acc offset i = if i >= n then acc else
let offset = line_offset filename offset in
aux (offset::acc) offset (succ i)
in
let row = aux [] offset 0 in
List.uniq row
let predlines n = compose n predline_offset
let succlines n filename offset = List.rev (compose n succline_offset filename offset)
(* extract a line with a maximal allowed length, and print it into the formatter *)
(* The offsets list is a list of first char of line *)
let extract_lines options fmt filename offsets =
let content = get_file_content filename in
let iter_trunc trunc offset =
let succline = succline_offset filename offset in
let all = succline - offset in
let line =
match trunc with
| Some trunc ->
if all > trunc then (String.sub content offset trunc)^"[...]\n"
else String.sub content offset all
| None ->
String.sub content offset all
in
Format.pp_print_string fmt line
in
try List.iter (iter_trunc options.truncate_lines) offsets
with
| Invalid_argument _ -> ()
(* print the right part of the string, including the index *)
let extract_right _options fmt filename offset =
let noff = fst (get_next_line filename offset) in
let noff = if noff = offset then fst (get_next_line filename (succ offset)) else noff in
let content = get_file_content filename in
Format.pp_print_string fmt (String.sub content offset (noff - offset))
(* print the left part of the line, excluding the index *)
let extract_left _options fmt filename offset =
let _, col = get_pos filename offset in
let content = get_file_content filename in
Format.pp_print_string fmt (String.sub content (offset-col) col)
(* usefull to print between two points (the stop of a range, and the start of the next) *)
let extract_between options fmt filename pointA pointB =
let lineA, _ = get_pos filename pointA in
let lineB, _ = get_pos filename pointB in
let content = get_file_content filename in
if lineB - lineA > options.lines_between
then (
let n = options.lines_between / 2 in
let succA = succlines n filename pointA in
let predB = predlines n filename pointB in
extract_right options fmt filename pointA ;
extract_lines options fmt filename succA ;
Format.pp_print_string fmt "[...]\n";
extract_lines options fmt filename predB ;
extract_left options fmt filename pointB
)
else
pp_print_string_sub fmt content pointA (pointB-pointA)
(* First version : Print the citation with some color *)
let unsafe_citation_files options fmt filerange =
let open_color, close_color =
match options.color with
| Some color -> Ansi.open_color_code color, Ansi.close_color_code
| None -> "<<<", ">>>"
in
let filename = filerange.filename in
Format.pp_print_string fmt (to_string_filerange filerange);
Format.pp_print_char fmt '\n';
let hdranges = filerange.ranges in
let content = get_file_content filename in
let first = HdList.hd hdranges in
let last = HdList.last hdranges in
let predlines = predlines options.lines_before filename first.start in
let succlines = succlines options.lines_after filename last.stop in
let offset_first, _ = get_line filename first.start in
let predlines = List.filter (fun l -> l <> offset_first) predlines in
let offset_last, _ = get_line filename last.stop in
let succlines = List.filter (fun l -> l <> offset_last) succlines in
Format.pp_print_string fmt "------citation-------\n" ;
Format.pp_print_string fmt "---------------------\n" ;
(* lines before *)
extract_lines options fmt filename predlines;
(* first part *)
extract_left options fmt filename first.start ;
(* Midle part *)
(* common part *)
let common r =
let start = r.start in
let stop = r.stop in
Format.pp_print_string fmt open_color;
pp_print_string_sub fmt content start (stop-start);
Format.pp_print_string fmt close_color;
in
let rec iter ranges =
match ranges with
| hd::((hd2::_) as tl) ->
common hd ;
extract_between options fmt filename hd.stop hd2.start ;
iter tl
| [last] ->
common last ;
(* in the last case case, we should extract the right part *)
extract_right options fmt filename last.stop
| [] -> assert false
in
iter (HdList.unwrap hdranges) ;
(* lines after *)
extract_lines options fmt filename succlines ;
Format.pp_print_char fmt '\n' ;
Format.pp_print_string fmt "---------------------\n" ;
Format.pp_print_string fmt "---end-of-citation---\n" ;
()
let citation_files options fmt filerange =
try unsafe_citation_files options fmt filerange
with Not_found -> no_citation fmt "<source file not available anymore>"
let citation ?(options=default_options) fmt pos =
match pos with
| Builtin pass -> no_citation fmt pass
| Files (files, _) ->
HdList.iter (citation_files options fmt) files
(* FIXME, consider re-implementing this function; it's
supposed to serve a single request so we don't have to
check line breaks after [pos]. *)
let get_pos_no_cache content pos =
let id = ref 0 in
let tmp_filename = Printf.sprintf "tmp-@%d@" !id in
incr id;
add_file tmp_filename content;
let res = get_pos tmp_filename pos in
uncache tmp_filename;
res
let pp_citation fmt pos = citation fmt pos
let pp = pp_pos