383 lines
11 KiB
OCaml
383 lines
11 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* OCaml *)
|
|
(* *)
|
|
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
open Lexing
|
|
|
|
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 symbol_rloc () = {
|
|
loc_start = Parsing.symbol_start_pos ();
|
|
loc_end = Parsing.symbol_end_pos ();
|
|
loc_ghost = false;
|
|
};;
|
|
|
|
let symbol_gloc () = {
|
|
loc_start = Parsing.symbol_start_pos ();
|
|
loc_end = Parsing.symbol_end_pos ();
|
|
loc_ghost = true;
|
|
};;
|
|
|
|
let rhs_loc n = {
|
|
loc_start = Parsing.rhs_start_pos n;
|
|
loc_end = Parsing.rhs_end_pos n;
|
|
loc_ghost = false;
|
|
};;
|
|
|
|
let input_name = ref "_none_"
|
|
let input_lexbuf = ref (None : lexbuf option)
|
|
|
|
(* Terminal info *)
|
|
|
|
let status = ref Terminfo.Uninitialised
|
|
|
|
let num_loc_lines = ref 0 (* number of lines already printed after input *)
|
|
|
|
(* Highlight the locations using standout mode. *)
|
|
|
|
let highlight_terminfo ppf num_lines lb locs =
|
|
Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *)
|
|
(* 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;
|
|
(* Count number of lines in phrase *)
|
|
let lines = ref !num_loc_lines in
|
|
for i = pos0 to lb.lex_buffer_len - 1 do
|
|
if Bytes.get lb.lex_buffer i = '\n' then incr lines
|
|
done;
|
|
(* If too many lines, give up *)
|
|
if !lines >= num_lines - 2 then raise Exit;
|
|
(* Move cursor up that number of lines *)
|
|
flush stdout; Terminfo.backup !lines;
|
|
(* Print the input, switching to standout for the location *)
|
|
let bol = ref false in
|
|
print_string "# ";
|
|
for pos = 0 to lb.lex_buffer_len - pos0 - 1 do
|
|
if !bol then (print_string " "; bol := false);
|
|
if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then
|
|
Terminfo.standout true;
|
|
if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
|
|
Terminfo.standout false;
|
|
let c = Bytes.get lb.lex_buffer (pos + pos0) in
|
|
print_char c;
|
|
bol := (c = '\n')
|
|
done;
|
|
(* Make sure standout mode is over *)
|
|
Terminfo.standout false;
|
|
(* Position cursor back to original location *)
|
|
Terminfo.resume !num_loc_lines;
|
|
flush stdout
|
|
|
|
(* 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 !status with
|
|
Terminfo.Uninitialised ->
|
|
status := Terminfo.setup stdout; highlight_locations ppf locs
|
|
| Terminfo.Bad_term ->
|
|
begin match !input_lexbuf with
|
|
None -> false
|
|
| Some lb ->
|
|
let norepeat =
|
|
try Sys.getenv "TERM" = "norepeat" with Not_found -> false in
|
|
if norepeat then false else
|
|
let loc1 = List.hd locs in
|
|
try highlight_dumb ppf lb loc1; true
|
|
with Exit -> false
|
|
end
|
|
| Terminfo.Good_term num_lines ->
|
|
begin match !input_lexbuf with
|
|
None -> false
|
|
| Some lb ->
|
|
try highlight_terminfo ppf num_lines lb locs; 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 print_warning loc ppf w =
|
|
if Warnings.is_active w then begin
|
|
let printw ppf w =
|
|
let n = Warnings.print ppf w in
|
|
num_loc_lines := !num_loc_lines + n
|
|
in
|
|
print ppf loc;
|
|
fprintf ppf "Warning %a@." printw w;
|
|
pp_print_flush ppf ();
|
|
incr num_loc_lines;
|
|
end
|
|
;;
|
|
|
|
let prerr_warning loc w = print_warning loc err_formatter w;;
|
|
|
|
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 collect_locs (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 (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" report_error err)
|
|
sub
|
|
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)
|
|
| Warnings.Errors n ->
|
|
Some
|
|
(errorf ~loc:(in_file !input_name)
|
|
"Error: Some fatal warnings were triggered (%d occurrences)" n)
|
|
| _ ->
|
|
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
|
|
)
|
|
|
|
let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") =
|
|
Printf.ksprintf (fun msg -> raise (Error ({loc; msg; sub; if_highlight})))
|