Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 537 lines (451 sloc) 16.842 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* CF MLI *)
19
20 module Format = BaseFormat
21 module List = BaseList
22
23 (* alias type *)
24
25 type filename = string
26 type content = string
27 type absolute_char_offset = int
28 type line_number = int
29 type column_number = int
30
31
32 (* cache mechanisme *)
33
34 (* memoize filename,content,offsetmap (first line char -> line)
35 globally to retrieve easily information from file on errors *)
36
37 let parsed_files : (string, (string * int IntMap.t)) Hashtbl.t = Hashtbl.create 16
38
39 (* an other cache for having the reverse map *)
40 let reverse_parsed_files : (string, int array) Hashtbl.t = Hashtbl.create 16
41
42 let debug () =
43 let iter file (_content, map) =
44 Printf.printf "File %S\n" file;
45 IntMap.iter (fun offset line -> Printf.printf "line %d -- global offset %d\n%!" line offset) map
46 in
47 Hashtbl.iter iter parsed_files
48
49 let get_file_content file =
50 fst (Hashtbl.find parsed_files file)
51
52 let uncache file =
53 Hashtbl.remove parsed_files file;
54 Hashtbl.remove reverse_parsed_files file
55
56 let clear () =
57 Hashtbl.clear parsed_files;
58 Hashtbl.clear reverse_parsed_files
59
60 (* compute maps of previous structure *)
61 let rec compute_lines content pos line map =
62 let len = String.length content in
63 if pos < len then
64 if
65 content.[pos] = '\n' ||
66 content.[pos] = '\r' && ( ( (pos<len-1) && content.[pos+1]<>'\n' ) ||
67 ( (pos>1 ) && content.[pos-1]<>'\n' ) )
68 then
69 compute_lines content (pos+1) (line+1) (IntMap.add (pos+1) (line+1) map)
70 else compute_lines content (pos+1) line map
71 else map
72
73 (* add a file to the memoization *)
74 let add_file file content =
75 let pos_line_map = compute_lines content 0 1 (IntMap.add 0 1 IntMap.empty) in
76 Hashtbl.replace parsed_files file (content, pos_line_map)
77
78 (* get the line and column number from a char position for a given file *)
79 let get_line_char file i =
80 let i = max 0 i in
81 let get_line_char map i =
82 let i_line, line_number = try IntMap.find_inf i map with Not_found -> (1,1) in
83 let char_in_line = i - i_line in
84 (line_number, char_in_line)
85 in
86 let _, map = Hashtbl.find parsed_files file in
87 get_line_char map i
88
89 let get_pos filename offset =
90 let getLine = get_line_char filename in
91 getLine offset
92
93 let get_pos_string (line, column) =
94 Printf.sprintf "line %d, column %d" line column
95
96 let get_line filename offset =
97 let offset = max 0 offset in
98 let line, col = get_pos filename offset in
99 (* Printf.fprintf stdout "get_line %d -> %d (line %d)\n%!" offset (offset - col) line; *)
100 offset-col, line
101
102 let get_next_line file i =
103 let default = (1, 1) in
104 try (
105 let _, map = Hashtbl.find parsed_files file in
106 try
107 IntMap.find_sup i map
108 with Not_found -> (
109 try IntMap.find_inf i map
110 with Not_found -> default
111 )
112 ) with Not_found -> default
113
114 let cache_reverse_map file array =
115 Hashtbl.add reverse_parsed_files file array
116
117 let build_reverse_map map =
118 let size = IntMap.size map in
119 let t = Array.make size 0 in
120 IntMap.iter (fun i j -> t.(pred j) <- i) map;
121 t
122
123 let line_position file line =
124 let lines =
125 try
126 Hashtbl.find reverse_parsed_files file
127 with
128 | Not_found ->
129 (* this can also raise Not_found *)
130 let _, map = Hashtbl.find parsed_files file in
131 let array = build_reverse_map map in
132 cache_reverse_map file array;
133 array
134 in
135 let len = Array.length lines in
136 if (1 <= line) && (line <= len)
137 then
138 let start = lines.(line-1) in
139 if line < len
140 then start, lines.(line)
141 else start, start
142 else raise Not_found
143
144 (* position tracking *)
145
146 type range = {
147 start : absolute_char_offset ;
148 stop : absolute_char_offset ;
149 }
150
151 type filerange = {
152 filename : filename ;
153 ranges : range HdList.t
154 }
155
156 type private_cache = {
157 mutable one_loc : (filename * line_number) option ;
158 }
159
160 type pos =
161 | Builtin of string
162 | Files of filerange HdList.t * private_cache
163
164 let make_cache () = {
165 one_loc = None ;
166 }
167
168 let nopos pass = Builtin pass
169 let get_file = function
170 | Builtin pass -> Printf.sprintf "builtin_%s" pass
171 | Files (hd, _) -> (HdList.hd hd).filename
172
173 let get_one_loc = function
174 | Builtin pass -> Printf.sprintf "builtin_%s" pass, 0
175 | Files (hd, cache) -> (
176 match cache.one_loc with
177 | Some loc -> loc
178 | None ->
179 let hd = HdList.hd hd in
180 let filename = hd.filename in
181 let start = (HdList.hd hd.ranges).start in
182 let _, line = get_line filename start in
183 let loc = filename, line in
184 cache.one_loc <- Some loc ;
185 loc
186 )
187
188 let get_first_char = function
189 | Builtin _ -> 0
190 | Files ((f, _), _) -> (fst f.ranges).start
191
192 let make_pos filename start stop =
193 if stop < start then invalid_arg "FilePos.make_pos" else
194 let range = { start = start ; stop = stop } in
195 Files (
196 (HdList.singleton { filename = filename ; ranges = HdList.singleton range } ),
197 make_cache ()
198 )
199 let cmp (a, _) (b, _) = compare a b
200 let sort_pos = List.sort cmp
201
202 let make_pos_from_line file line =
203 try
204 let start, stop = line_position file line in
205 let pos = make_pos file start stop in
206 let () =
207 match pos with
208 | Files (_, cache) -> cache.one_loc <- Some (file, line)
209 | _ -> ()
210 in
211 pos
212 with
213 | Not_found ->
214 nopos (Printf.sprintf "File %S, line %d:" file line)
215
216 let merge_range {start = x1; stop = y1} {start = x2; stop = y2} =
217 {start = min x1 x2; stop = max y1 y2}
218
219 let merge_pos_for_parser p1 p2 =
220 match p1, p2 with
221 | Files (({filename=filename1;ranges=(range1,[])},[]), _),
222 Files (({filename=filename2;ranges=(range2,[])},[]), _) ->
223 assert (filename1 = filename2);
224 Files (
225 ({filename=filename1; ranges = (merge_range range1 range2, [])}, []),
226 make_cache()
227 )
228 | _ -> assert false
229
230 (* very bad complexity, but in practice the list are very little (less than 20 files) *)
231 module LH = ListHashtbl
232 let merge_pos p1 p2 =
233 match p1, p2 with
234 | Builtin _, a | a, Builtin _ -> a
235 | Files (r, _), Files (r', _) -> (
236 let lh = LH.create 10 in
237 (* collect by filenames *)
238 let iter f =
239 let filename = f.filename in
240 HdList.iter (fun r -> LH.add lh filename (r.start, r.stop)) f.ranges in
241 HdList.iter iter r ;
242 HdList.iter iter r';
243 (* insertion of a segment in a segment list sorted by start *)
244 let rec merge acc ((start, stop) as seg) =
245 match acc with
246 | [] -> [ seg ]
247 | ((start', stop') as hd)::tl ->
248 if start > stop' + 1 then hd::(merge tl seg)
249 else
250 if stop < start' - 1 then seg::acc
251 else
252 (min start start', max stop stop')::tl
253 in
254 let collect filename segs acc =
255 let segs = List.fold_left merge [] segs in
256 let ranges = List.fold_left (fun acc (start, stop) -> { start = start ; stop = stop } :: acc ) [] segs in
257 { filename = filename ; ranges = HdList.wrap (List.rev ranges) } :: acc
258 in
259 let ranges = List.rev (LH.fold_list collect lh []) in
260 Files ((HdList.wrap ranges), make_cache())
261 )
262
263 let merge_pos_list = function
264 | [] -> invalid_arg "FilePos.merge_pos_list"
265 | h :: t -> List.fold_left merge_pos h t
266
267 let is_empty = function
268 | Builtin _ -> true
269 | _ -> false
270
271 let to_string_range filename r =
272 let start = r.start in
273 let stop = r.stop in
274 try
275 let line1, col1 = get_pos filename start in
276 let line2, col2 = get_pos filename stop in
277 (* Do not change the layout there, or update in the opa-mode the variable compilation-error-regexp-alist *)
278 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
279 (#<If:TESTING> 0 #<Else> start #<End>)
280 (#<If:TESTING> 0 #<Else> stop #<End>)
281 with
282 | Not_found ->
283 Printf.sprintf "File %S (%d-%d)" filename start stop
284
285 let pp_filerange filename fmt r =
286 Format.pp_print_string fmt (to_string_range filename r)
287
288 let pp_filerange fmt {filename=filename; ranges=ranges} =
289 let ranges = HdList.unwrap ranges in
290 Format.pp_list "@\n" (pp_filerange filename) fmt ranges
291
292 let pp_pos fmt = function
293 | Builtin pass -> Format.fprintf fmt "<no position available (%s)>" pass
294 | Files (files, _) ->
295 let files = HdList.unwrap files in
296 Format.pp_list "@\n" pp_filerange fmt files
297
298 let pp_files fmt = function
299 | Builtin pass -> Format.fprintf fmt "<no file available (%s)>" pass
300 | Files (files, _) ->
301 let files = HdList.unwrap files in
302 Format.pp_list ", " (fun fmt v -> Format.pp_print_string fmt v.filename) fmt files
303
304 let to_string_filerange f = Format.to_string pp_filerange f
305 let to_string p = Format.to_string pp_pos p
306
307 (* deprecated API *)
308 let to_old_pos_many = function
309 | Builtin _ -> StringMap.empty
310 | Files (fileranges, _) ->
311 let translate {start = d; stop = f} = (d, f) in
312 let fold map f =
313 let file = f.filename in
314 let r, ranges = f.ranges in
315 let wrong = List.fold_left merge_range r ranges in
316 StringMap.add file (translate wrong) map
317 in
318 HdList.fold_left fold StringMap.empty fileranges
319
320 let to_old_pos nopos = function
321 | Builtin _ -> nopos ()
322 | Files ((f, _), _) ->
323 let r = fst f.ranges in
324 f.filename, r.start, r.stop
325
326 (* citations *)
327
328 (*
329 The effeciency is not a goal, because we are just printing once a citation in case
330 of error. So, do not hack the code for unused optimisation, keep it rather simple.
331 *)
332
333 type options = {
334 truncate_lines : int option ;
335 lines_before : int ;
336 lines_after : int ;
337 lines_between : int ;
338 color : Ansi.color option ;
339 max_length_citation : int option ;
340 }
341
342 let default_options = {
343 truncate_lines = Some 80 ;
344 lines_before = 5 ;
345 lines_after = 5 ;
346 lines_between = 5 ;
347 color = Some ( `red : Ansi.color ) ;
348 max_length_citation = Some 200 ;
349 }
350
351 (* Shame : no Format.pp_print_string_sub ? *)
352 let pp_print_string_sub fmt content offset len = Format.pp_print_string fmt (String.sub content offset len)
353
354 let no_citation fmt pass =
355 Format.fprintf fmt "%s (no-citation-available)@\n" pass
356
357 (* ALL THE FOLLOWING FUNCTIONS MAY RAISE NOT_FOUND, BUT THEY ARE ALL USED ONLY
358 INTERNALLY BY THE FUNCTION CITATION, WHICH CATCH THE EXCEPTION.
359 *)
360
361 (* this function return the global offset of the first char of the previous line of the line which contains the char offset *)
362 (*
363
364 called with the offset of m :
365
366 p
367 m
368
369 it returns the offset of p
370 *)
371 let predline_offset filename offset =
372 let offset, _ = get_line filename offset in
373 let offset, _ = get_line filename (pred offset) in
374 offset
375
376 (* symetric *)
377 let succline_offset filename offset =
378 let offset, _ = get_next_line filename (succ offset) in
379 offset
380
381 (* compose predline or succ line, return the sorted offset of successive lines *)
382 let compose n line_offset filename offset =
383 let rec aux acc offset i = if i >= n then acc else
384 let offset = line_offset filename offset in
385 aux (offset::acc) offset (succ i)
386 in
387 let row = aux [] offset 0 in
388 List.uniq row
389
390 let predlines n = compose n predline_offset
391 let succlines n filename offset = List.rev (compose n succline_offset filename offset)
392
393 (* extract a line with a maximal allowed length, and print it into the formatter *)
394 (* The offsets list is a list of first char of line *)
395 let extract_lines options fmt filename offsets =
396 let content = get_file_content filename in
397 let iter_trunc trunc offset =
398 let succline = succline_offset filename offset in
399 let all = succline - offset in
400 let line =
401 match trunc with
402 | Some trunc ->
403 if all > trunc then (String.sub content offset trunc)^"[...]\n"
404 else String.sub content offset all
405 | None ->
406 String.sub content offset all
407 in
408 Format.pp_print_string fmt line
409 in
410 try List.iter (iter_trunc options.truncate_lines) offsets
411 with
412 | Invalid_argument _ -> ()
413
414 (* print the right part of the string, including the index *)
415 let extract_right _options fmt filename offset =
416 let noff = fst (get_next_line filename offset) in
417 let noff = if noff = offset then fst (get_next_line filename (succ offset)) else noff in
418 let content = get_file_content filename in
419 Format.pp_print_string fmt (String.sub content offset (noff - offset))
420
421 (* print the left part of the line, excluding the index *)
422 let extract_left _options fmt filename offset =
423 let _, col = get_pos filename offset in
424 let content = get_file_content filename in
425 Format.pp_print_string fmt (String.sub content (offset-col) col)
426
427 (* usefull to print between two points (the stop of a range, and the start of the next) *)
428 let extract_between options fmt filename pointA pointB =
429 let lineA, _ = get_pos filename pointA in
430 let lineB, _ = get_pos filename pointB in
431 let content = get_file_content filename in
432 if lineB - lineA > options.lines_between
433 then (
434 let n = options.lines_between / 2 in
435 let succA = succlines n filename pointA in
436 let predB = predlines n filename pointB in
437 extract_right options fmt filename pointA ;
438 extract_lines options fmt filename succA ;
439 Format.pp_print_string fmt "[...]\n";
440 extract_lines options fmt filename predB ;
441 extract_left options fmt filename pointB
442 )
443 else
444 pp_print_string_sub fmt content pointA (pointB-pointA)
445
446 (* First version : Print the citation with some color *)
447 let unsafe_citation_files options fmt filerange =
448 let open_color, close_color =
449 match options.color with
450 | Some color -> Ansi.open_color_code color, Ansi.close_color_code
451 | None -> "<<<", ">>>"
452 in
453 let filename = filerange.filename in
454
455 Format.pp_print_string fmt (to_string_filerange filerange);
456 Format.pp_print_char fmt '\n';
457
458 let hdranges = filerange.ranges in
459 let content = get_file_content filename in
460 let first = HdList.hd hdranges in
461 let last = HdList.last hdranges in
462
463 let predlines = predlines options.lines_before filename first.start in
464 let succlines = succlines options.lines_after filename last.stop in
465
466 let offset_first, _ = get_line filename first.start in
467 let predlines = List.filter (fun l -> l <> offset_first) predlines in
468 let offset_last, _ = get_line filename last.stop in
469 let succlines = List.filter (fun l -> l <> offset_last) succlines in
470
471 Format.pp_print_string fmt "------citation-------\n" ;
472 Format.pp_print_string fmt "---------------------\n" ;
473
474 (* lines before *)
475 extract_lines options fmt filename predlines;
476
477 (* first part *)
478 extract_left options fmt filename first.start ;
479
480 (* Midle part *)
481 (* common part *)
482 let common r =
483 let start = r.start in
484 let stop = r.stop in
485 Format.pp_print_string fmt open_color;
486 pp_print_string_sub fmt content start (stop-start);
487 Format.pp_print_string fmt close_color;
488 in
489
490 let rec iter ranges =
491 match ranges with
492 | hd::((hd2::_) as tl) ->
493 common hd ;
494 extract_between options fmt filename hd.stop hd2.start ;
495 iter tl
496 | [last] ->
497 common last ;
498 (* in the last case case, we should extract the right part *)
499 extract_right options fmt filename last.stop
500 | [] -> assert false
501 in
502 iter (HdList.unwrap hdranges) ;
503
504 (* lines after *)
505 extract_lines options fmt filename succlines ;
506 Format.pp_print_char fmt '\n' ;
507
508 Format.pp_print_string fmt "---------------------\n" ;
509 Format.pp_print_string fmt "---end-of-citation---\n" ;
510
511 ()
512
513 let citation_files options fmt filerange =
514 try unsafe_citation_files options fmt filerange
515 with Not_found -> no_citation fmt "<source file not available anymore>"
516
517 let citation ?(options=default_options) fmt pos =
518 match pos with
519 | Builtin pass -> no_citation fmt pass
520 | Files (files, _) ->
521 HdList.iter (citation_files options fmt) files
522
523 (* FIXME, consider re-implementing this function; it's
524 supposed to serve a single request so we don't have to
525 check line breaks after [pos]. *)
526 let get_pos_no_cache content pos =
527 let id = ref 0 in
528 let tmp_filename = Printf.sprintf "tmp-@%d@" !id in
529 incr id;
530 add_file tmp_filename content;
531 let res = get_pos tmp_filename pos in
532 uncache tmp_filename;
533 res
534
535 let pp_citation fmt pos = citation fmt pos
536 let pp = pp_pos
Something went wrong with that request. Please try again.