ocaml/parsing/location.ml

(**************************************************************************)
(*                                                                        *)
(*                                 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 GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

open Lexing

type t = Warnings.loc =
  { loc_start: position; loc_end: position; loc_ghost: bool };;

let in_file name =
  let loc = { dummy_pos with pos_fname = name } 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 rhs_interval m n = {
  loc_start = Parsing.rhs_start_pos m;
  loc_end = Parsing.rhs_end_pos n;
  loc_ghost = false;
};;

(* 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)
;;

type 'a loc = {
  txt : 'a;
  loc : t;
}

let mkloc txt loc = { txt ; loc }
let mknoloc txt = mkloc txt none

(******************************************************************************)
(* Input info *)

let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)

(******************************************************************************)
(* Terminal info *)

let status = ref Terminfo.Uninitialised

let setup_terminal () =
  if !status = Terminfo.Uninitialised then
    status := Terminfo.setup stdout

(* The number of lines already printed after input.

   This is used by [highlight_terminfo] to identify the current position of the
   input in the terminal. This would not be possible without this information,
   since printing several warnings/errors adds text between the user input and
   the bottom of the terminal.
*)
let num_loc_lines = ref 0

(* This is used by the toplevel to reset [num_loc_lines] before each phrase *)
let reset () =
  num_loc_lines := 0

(* This is used by the toplevel *)
let echo_eof () =
  print_newline ();
  incr num_loc_lines

(* Code printing errors and warnings must be wrapped using this function, in
   order to update [num_loc_lines].

   [print_updating_num_loc_lines ppf f arg] is equivalent to calling [f ppf
   arg], and additionally updates [num_loc_lines]. *)
let print_updating_num_loc_lines ppf f arg =
  let open Format in
  let out_functions = pp_get_formatter_out_functions ppf () in
  let out_string str start len =
    let rec count i c =
      if i = start + len then c
      else if String.get str i = '\n' then count (succ i) (succ c)
      else count (succ i) c in
    num_loc_lines := !num_loc_lines + count start 0 ;
    out_functions.out_string str start len in
  pp_set_formatter_out_functions ppf
    { out_functions with out_string } ;
  f ppf arg ;
  pp_print_flush ppf ();
  pp_set_formatter_out_functions ppf out_functions

let setup_colors () =
  Misc.Color.setup !Clflags.color

(******************************************************************************)
(* Printing locations, e.g. 'File "foo.ml", line 3, characters 10-12' *)

let rewrite_absolute_path path =
  match Misc.get_build_path_prefix_map () with
  | None -> path
  | Some map -> Build_path_prefix_map.rewrite map path

let absolute_path s = (* This function could go into Filename *)
  let open Filename in
  let s =
    if not (is_relative s) then s
    else (rewrite_absolute_path (concat (Sys.getcwd ()) 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 !Clflags.absname then absolute_path file else file

let print_filename ppf file =
  Format.pp_print_string ppf (show_filename file)

(* Best-effort printing of the text describing a location, of the form
   'File "foo.ml", line 3, characters 10-12'.

   Some of the information (filename, line number or characters numbers) in the
   location might be invalid; in which case we do not print it.
 *)
let print_loc ppf loc =
  setup_colors ();
  let file_valid = function
    | "_none_" ->
        (* This is a dummy placeholder, but we print it anyway to please editors
           that parse locations in error messages (e.g. Emacs). *)
        true
    | "" | "//toplevel//" -> false
    | _ -> true
  in
  let line_valid line = line > 0 in
  let chars_valid ~startchar ~endchar = startchar <> -1 && endchar <> -1 in

  let file =
    (* According to the comment in location.mli, if [pos_fname] is "", we must
       use [!input_name]. *)
    if loc.loc_start.pos_fname = "" then !input_name
    else loc.loc_start.pos_fname
  in
  let line = loc.loc_start.pos_lnum in
  let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in
  let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_bol in

  let first = ref true in
  let capitalize s =
    if !first then (first := false; String.capitalize_ascii s)
    else s in
  let comma () =
    if !first then () else Format.fprintf ppf ", " in

  Format.fprintf ppf "@{<loc>";

  if file_valid file then
    Format.fprintf ppf "%s \"%a\"" (capitalize "file") print_filename file;

  (* Print "line 1" in the case of a dummy line number. This is to please the
     existing setup of editors that parse locations in error messages (e.g.
     Emacs). *)
  comma ();
  Format.fprintf ppf "%s %i" (capitalize "line")
    (if line_valid line then line else 1);

  if chars_valid ~startchar ~endchar then (
    comma ();
    Format.fprintf ppf "%s %i-%i" (capitalize "characters") startchar endchar
  );

  Format.fprintf ppf "@}"

(* Print a comma-separated list of locations *)
let print_locs ppf locs =
  Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")
    print_loc ppf locs

(******************************************************************************)
(* Toplevel: highlighting and quoting locations *)

(* Highlight the locations using standout mode.

   If [locs] is empty, this function is a no-op.
*)
let highlight_terminfo lb ppf 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 >= Terminfo.num_lines stdout - 2 then raise Exit;
  (* Move cursor up that number of lines *)
  flush stdout; Terminfo.backup stdout !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 stdout true;
    if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then
      Terminfo.standout stdout 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 stdout false;
  (* Position cursor back to original location *)
  Terminfo.resume stdout !num_loc_lines;
  flush stdout

let highlight_terminfo lb ppf locs =
  try highlight_terminfo lb ppf locs
  with Exit -> ()

(* Highlight the location by printing it again.

   There are two different styles for highlighting errors in "dumb" mode,
   depending if the error fits on a single line or spans across several lines.

   For single-line errors,

     foo the_error bar

   gets displayed as:

     foo the_error bar
         ^^^^^^^^^


   For multi-line errors,

     foo the_
     error bar

   gets displayed as:

     ....the_
     error....

   If [locs] is empty then this function is a no-op.
*)
let highlight_dumb lb ppf locs =
  let locs' = Misc.Stdlib.List.filter_map (fun loc ->
    let s, e = loc.loc_start.pos_cnum, loc.loc_end.pos_cnum in
    (* Ignore dummy locations *)
    if s = -1 || e = -1 then None
    else Some (s, e)
  ) locs
  in
  if locs' = [] then ()
  else begin
    (* Helper to check if a given position is to be highlighted *)
    let is_highlighted pos =
      List.exists (fun (s, e) -> s <= pos && pos < e) locs' in
    (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *)
    let pos0 = -lb.lex_abs_pos in
    (* Helper to read a char in the buffer *)
    let read_char pos = Bytes.get lb.lex_buffer (pos + pos0) 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
    (* Leftmost starting position of all locations *)
    let leftmost_start, _ =
      List.hd @@ List.sort (fun (s, _) (s', _) -> compare s s') locs' in
    (* Rightmost ending position of all locations *)
    let _, rightmost_end =
      List.hd @@ List.sort (fun (_, e) (_, e') -> compare e' e) locs' in
    (* Determine line numbers and positions for the start and end points *)
    let line_start, line_end, line_start_pos, line_end_pos =
      let line_start = ref 0 and line_end = ref 0 in
      let line_start_pos = ref 0 and line_end_pos = ref 0 in
      let rec loop pos line line_bol_pos =
        if pos > end_pos then ()
        else if read_char pos = '\n' then
          let line_bol_pos' = pos + 1 in
          if line_bol_pos <= leftmost_start
          && leftmost_start < line_bol_pos' then begin
            line_start := line;
            line_start_pos := line_bol_pos
          end;
          if line_bol_pos <= rightmost_end
          && rightmost_end < line_bol_pos' then begin
            line_end := line;
            line_end_pos := pos
          end;
          loop (pos + 1) (line + 1) line_bol_pos'
        else
          loop (pos + 1) line line_bol_pos
      in
      loop 0 0 0;
      !line_start, !line_end, !line_start_pos, !line_end_pos
    in
    Format.fprintf ppf "@[<v>";
    (* Print the input, highlighting the locations.
       Indent by two spaces. *)
    Format.fprintf ppf "  @[<v>";
    if line_start = line_end then begin
      (* single-line error *)
      for pos = line_start_pos to line_end_pos - 1 do
        Format.pp_print_char ppf (read_char pos)
      done;
      Format.fprintf ppf "@,";
      for pos = line_start_pos to rightmost_end - 1 do
        if is_highlighted pos then Format.pp_print_char ppf '^'
        else Format.pp_print_char ppf ' '
      done
    end else begin
      (* multi-line error *)
      for pos = line_start_pos to line_end_pos - 1 do
        let c = read_char pos in
        if c = '\n' then Format.fprintf ppf "@,"
        else if is_highlighted pos then Format.pp_print_char ppf c
        else Format.pp_print_char ppf '.'
      done
    end;
    Format.fprintf ppf "@]@,@]"
  end

let highlight_dumb lb ppf locs =
  try highlight_dumb lb ppf locs with Exit -> ()

(******************************************************************************)
(* Reporting errors and warnings *)

type msg = (Format.formatter -> unit) loc

let msg ?(loc = none) fmt =
  Format.kdprintf (fun txt -> { loc; txt }) fmt

type report_kind =
  | Report_error
  | Report_warning of int
  | Report_warning_as_error of int

type report = {
  kind : report_kind;
  main : msg;
  sub : msg list;
}

type report_printer = {
  (* The entry point *)
  pp : report_printer ->
    Format.formatter -> report -> unit;

  pp_report_kind : report_printer -> report ->
    Format.formatter -> report_kind -> unit;
  pp_main_loc : report_printer -> report ->
    Format.formatter -> t -> unit;
  pp_main_txt : report_printer -> report ->
    Format.formatter -> (Format.formatter -> unit) -> unit;
  pp_submsgs : report_printer -> report ->
    Format.formatter -> msg list -> unit;
  pp_submsg : report_printer -> report ->
    Format.formatter -> msg -> unit;
  pp_submsg_loc : report_printer -> report ->
    Format.formatter -> t -> unit;
  pp_submsg_txt : report_printer -> report ->
    Format.formatter -> (Format.formatter -> unit) -> unit;
}

let batch_mode_printer : report_printer =
  let pp_loc ppf loc = Format.fprintf ppf "%a:@ " print_loc loc in
  let pp_txt ppf txt = Format.fprintf ppf "@[%t@]" txt in
  let pp self ppf report =
    setup_colors ();
    Format.fprintf ppf "@[<v>%a%a: %a%a@]@."
      (self.pp_main_loc self report) report.main.loc
      (self.pp_report_kind self report) report.kind
      (self.pp_main_txt self report) report.main.txt
      (self.pp_submsgs self report) report.sub
  in
  let pp_report_kind _self _ ppf = function
    | Report_error -> Format.fprintf ppf "@{<error>Error@}"
    | Report_warning w -> Format.fprintf ppf "@{<warning>Warning@} %d" w
    | Report_warning_as_error w ->
        Format.fprintf ppf "@{<error>Error@} (warning %d)" w
  in
  let pp_main_loc _self _ ppf loc =
    pp_loc ppf loc
  in
  let pp_main_txt _self _ ppf txt =
    pp_txt ppf txt
  in
  let pp_submsgs self report ppf msgs =
    List.iter (fun msg ->
      Format.fprintf ppf "@,%a" (self.pp_submsg self report) msg
    ) msgs
  in
  let pp_submsg self report ppf { loc; txt } =
    Format.fprintf ppf "@[<hv 2>%a%a@]"
      (self.pp_submsg_loc self report) loc
      (self.pp_submsg_txt self report) txt
  in
  let pp_submsg_loc _self _ ppf loc =
    if not loc.loc_ghost then
      pp_loc ppf loc
  in
  let pp_submsg_txt _self _ ppf loc =
    pp_txt ppf loc
  in
  { pp; pp_report_kind; pp_main_loc; pp_main_txt;
    pp_submsgs; pp_submsg; pp_submsg_loc; pp_submsg_txt }

let is_dummy_loc loc =
  (* Fixme: this should be just [loc.loc_ghost] and the function should be
     inlined below. However, currently, the compiler emits in some places ghost
     locations with valid ranges that should still be printed. These locations
     should be made non-ghost -- in the meantime we just check if the ranges are
     valid. *)
  loc.loc_start.pos_cnum = -1 || loc.loc_end.pos_cnum = -1

(* It only makes sense to highlight (i.e. quote or underline the corresponding
   source code) locations that originate from the toplevel. *)
let is_toplevel_loc loc =
  not (is_dummy_loc loc)
  && loc.loc_start.pos_fname = "//toplevel//"
  && loc.loc_end.pos_fname = "//toplevel//"

let dumb_toplevel_printer (lb: lexbuf): report_printer =
  let pp self ppf err =
    setup_colors ();
    (* Since we're printing in the toplevel, we have to keep [num_loc_lines]
       updated. *)
    print_updating_num_loc_lines ppf (batch_mode_printer.pp self) err
  in
  let pp_loc _ _ ppf loc =
    let highlight ppf loc =
      if is_toplevel_loc loc then highlight_dumb lb ppf [loc] in
    Format.fprintf ppf "@[<v>%a:@,%a@]" print_loc loc highlight loc
  in
  { batch_mode_printer with pp; pp_main_loc = pp_loc; pp_submsg_loc = pp_loc }

let terminfo_toplevel_printer (lb: lexbuf): report_printer =
  let pp self ppf err =
    setup_colors ();
    (* Highlight all toplevel locations of the report, instead of displaying
       the main location. Do it now instead of in [pp_main_loc], to avoid
       messing with Format boxes. *)
    let sub_locs = List.map (fun { loc; _ } -> loc) err.sub in
    let all_locs = err.main.loc :: sub_locs in
    let locs_highlighted = List.filter is_toplevel_loc all_locs in
    highlight_terminfo lb ppf locs_highlighted;
    (* Make sure we keep [num_loc_lines] updated. *)
    print_updating_num_loc_lines ppf (batch_mode_printer.pp self) err
  in
  let pp_main_loc _ _ _ _ = () in
  { batch_mode_printer with pp; pp_main_loc }

let best_toplevel_printer () =
  setup_terminal ();
  match !status, !input_lexbuf with
  | Terminfo.Good_term, Some lb ->
      terminfo_toplevel_printer lb
  | Terminfo.Bad_term, Some lb ->
      dumb_toplevel_printer lb
  | _, _ ->
      batch_mode_printer

(* Creates a printer for the current input *)
let default_report_printer () : report_printer =
  if !input_name = "//toplevel//" then
    best_toplevel_printer ()
  else
    batch_mode_printer

let report_printer = ref default_report_printer

let print_report ppf report =
  let printer = !report_printer () in
  printer.pp printer ppf report

(******************************************************************************)
(* Reporting errors *)

type error = report

let report_error ppf err =
  print_report ppf err

let mkerror loc sub txt =
  { kind = Report_error; main = { loc; txt }; sub }

let errorf ?(loc = none) ?(sub = []) =
  Format.kdprintf (mkerror loc sub)

let error ?(loc = none) ?(sub = []) msg_str =
  mkerror loc sub (fun ppf -> Format.pp_print_string ppf msg_str)

let error_of_printer ?(loc = none) ?(sub = []) pp x =
  mkerror loc sub (fun ppf -> pp ppf x)

let error_of_printer_file print x =
  error_of_printer ~loc:(in_file !input_name) print x

(******************************************************************************)
(* Reporting warnings: generating a report from a warning number using the
   information in [Warnings] + convenience functions. *)

let default_warning_reporter (loc: t) (w: Warnings.t): report option =
  match Warnings.report w with
  | `Inactive -> None
  | `Active { Warnings.number; message; is_error; sub_locs } ->
      let msg_of_str str = fun ppf -> Format.pp_print_string ppf str in
      let kind =
        if is_error then Report_warning_as_error number
        else Report_warning number in
      let main = { loc; txt = msg_of_str message } in
      let sub = List.map (fun (loc, sub_message) ->
        { loc; txt = msg_of_str sub_message }
      ) sub_locs in
      Some { kind; main; sub }

let warning_reporter = ref default_warning_reporter
let report_warning loc w = !warning_reporter loc w

let formatter_for_warnings = ref Format.err_formatter

let print_warning loc ppf w =
  match report_warning loc w with
  | None -> ()
  | Some report -> print_report ppf report

let prerr_warning loc w = print_warning loc !formatter_for_warnings w

let deprecated ?(def = none) ?(use = none) loc msg =
  prerr_warning loc (Warnings.Deprecated (msg, def, use))

(******************************************************************************)
(* Reporting errors on exceptions *)

let error_of_exn : (exn -> error option) list ref = ref []

let register_error_of_exn f = error_of_exn := f :: !error_of_exn

exception Already_displayed_error = Warnings.Errors

let error_of_exn exn =
  match exn with
  | Already_displayed_error -> Some `Already_displayed
  | _ ->
     let rec loop = function
       | [] -> None
       | f :: rest ->
          match f exn with
          | Some error -> Some (`Ok error)
          | None -> loop rest
     in
     loop !error_of_exn

let () =
  register_error_of_exn
    (function
      | Sys_error msg ->
          Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg)

      | Misc.HookExnWrapper {error = e; hook_name;
                             hook_info={Misc.sourcefile}} ->
          let sub = match error_of_exn e with
            | None | Some `Already_displayed ->
                [msg "%s" (Printexc.to_string e)]
            | Some (`Ok err) ->
                (msg ~loc:err.main.loc "%t" err.main.txt) :: err.sub
          in
          Some
            (errorf ~loc:(in_file sourcefile) ~sub "In hook %S:" hook_name)
      | _ -> None
    )

external reraise : exn -> 'a = "%reraise"

let report_exception ppf exn =
  let rec loop n exn =
    match error_of_exn exn with
    | None -> reraise exn
    | Some `Already_displayed -> ()
    | Some (`Ok err) -> report_error ppf err
    | exception exn when n > 0 -> loop (n-1) exn
  in
  loop 5 exn

exception Error of error

let () =
  register_error_of_exn
    (function
      | Error e -> Some e
      | _ -> None
    )

let raise_errorf ?(loc = none) ?(sub = []) =
  Format.kdprintf (fun txt -> raise (Error (mkerror loc sub txt)))